home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Nuc source / Nuc1.asm < prev    next >
Assembly Source File  |  1995-12-10  |  94KB  |  4,139 lines
  1. LoBaseRange    equ    * + $20C0    ; Just before the first dic header
  2. base    equ    LoBaseRange + 32768
  3.  
  4. ; We put base up there, so that we have a full 64K addressing range
  5. ; based on A3.
  6.  
  7. AbsZero    equ    0
  8.  
  9.     A5sec
  10.  
  11. saveEP    long
  12.  
  13.     A5end
  14.  
  15.  
  16. ;    =========================
  17.  
  18. ; Our Setup segment JMPs to Main.  A6 and A7 are the "system" way round, not the
  19. ; "Mops" way -- A7 is the data stack pointer at this point.
  20.  
  21. start
  22. Main
  23.     lea    LoBaseRange,A3    ; Set A3 -> lobase before we do
  24.     add.l    #$8000,A3    ;  anything else!
  25.     move.l    A3,A4
  26.     add.l    #$10000-2,A4    ; Set A4 -> hibase, 64K-4 above lobase
  27.  
  28.     tst.b    itzed+3-base(a3)    ; Are we initialized already?
  29.     bne    quit    ; Yes - try going straight to QUIT
  30.             ;  - it may work!
  31.     st    itzed+3-base(a3)    ; No - mark us initialized
  32.     lea    EnterProc,a0
  33.     move.l    a0,saveEP    ; Save EnterProc address for :PROC
  34.     pea    start    ; Restart address after a bomb
  35.     _InitDialogs    ; (resumeProc:ProcPtr)
  36.  
  37. ; Now we set various quantities saved by Setup.
  38.  
  39.     move.l    d7,RP0-base(a3)
  40.     move.l    d6,SP0-base(a3)
  41.     move.l    d6,a0
  42.     addq    #8,a0
  43.     lea    abort,a1    ; We leave the addrs of ABORT and BYE
  44.     move.l    a1,(a0)+    ; under the markers which are just
  45.     lea    bye,a1    ; under SP0, so we can recover in Macsbug.
  46.     move.l    a1,(a0)+    ; ("under" from a stack point of view
  47.             ;  actually means higher addresses)
  48.     move.b    d5,GestaltAvail+3-base(a3)
  49.     lsr.l    #8,d5
  50.     move.b    d5,HWPavail+3-base(a3)
  51.     lsr.l    #8,d5
  52.     move.b    d5,WNEavail+3-base(a3)
  53.     move.l    d4,SAmask-base(a3)
  54.     move.l    (a7)+,FPUq-base(a3)
  55.     move.l    (a7)+,d3
  56.     move.l    d3,processor-base(a3)
  57.     subq    #1,d3    ; Are we running on a 68000?
  58.     beq.s    .getinf
  59.     move.l    nops,star-base(a3)    ; No - 68020 or later.  Here we
  60.     move.l    nops,slash-base(a3)    ; NOP out the (long) branches to the
  61.     move.l    nops,mod-base(a3)    ; software 32-bit multiply and divide
  62.     move.l    nops,slMod-base(a3)    ; routines, so that the hardware
  63.     move.l    nops,UslMod-base(a3)    ; equivalents will be used instead.
  64.     move.l    nops,mulx-base(a3)
  65.     bsr    patchesDone
  66.  
  67. nops    nop
  68.     nop
  69.  
  70. .getinf    movem.l    (a2)+,d0-d4    ; A2 -> info block at start of Setup
  71.     move.l    d0,maxDic-base(a3)
  72.     move.l    d1,minHeap-base(a3)
  73.     move.l    d2,dicSize-base(a3)
  74.     move.l    d3,stkSpace-base(a3)
  75.     move.l    d4,RstkSpace-base(a3)
  76.  
  77. ; We're now finished with Setup, so we can unload it.
  78. ; Note A2 -> Run, as required for _UnloadSeg.
  79.  
  80.     move.l    a2,-(a7)
  81.     _UnloadSeg
  82.  
  83. ; Now we initialize the number base, LATEST and DP.
  84.  
  85.     moveq    #10,d1
  86.     move.l    d1,nbase-base(A3)
  87.     move.b    instldq+3,d0    ; if we're installed, DP is OK already
  88.     bne.s    .gte
  89.     lea    lastname,A0
  90.     move.l    A0,latest-base(A3)
  91.     lea    start_dp,A0
  92.     move.l    A0,DP-base(A3)
  93.  
  94. ; Now we get the trap address for _BlockMove, to save the trap dispatcher time.
  95.  
  96. .gte    MOVE.W    #$2E,D0
  97.     _GetTrapAddressOS
  98.     move.l    a0,BMaddr-base(a3)
  99.  
  100. ; Now we allocate a block for fFcb, TIB, PAD and the error dump area, and set fFcb
  101. ; (which is an object pointer) pointing there.
  102.  
  103.     move.l    #FBlkLen+10,d0    ; The 10 is just a safety margin --
  104.             ; we only have to add 8 for object header.
  105.     dc.w    $A31E    ; _NewPtr,clear
  106.     bne    .startupErr    ; If we didn't get the block, we PANIC!!!
  107.     addq    #8,a0    ; Leave room for the obj header
  108.     move.l    a0,fFcb-base(a3)    ; which will be set up when Files is 
  109.             ;  loaded.
  110.     add.w    #FCBlen,a0
  111.     move.l    a0,PAD-base(a3)
  112.     add.w    #PADlen,a0
  113.     move.l    a0,TIB-base(a3)
  114.     add.w    #TIBlen,a0
  115.     move.l    a0,PtrErrDump-base(a3)
  116.  
  117. ; Now we allocate theRgn, which is a RegionHandle we use when we make system calls
  118. ; that require a region:
  119.  
  120.     CLR.L    -(SP)
  121.     _NewRgn        ; :RgnHandle
  122.     MOVE.L    (SP)+,TheRgn-base(A3)
  123.  
  124. ; Now we set up for AppleEvents, if they're available.
  125.  
  126.     sf    AppleEventsQ+3-base(a3)    ; Initially assume no AppleEvents
  127.     tst.b    GestaltAvail+3-base(a3)
  128.     beq    .getdic    ; If no Gestalt, no AppleEvents either.
  129.  
  130.     move.l    #'evnt',d0
  131.     _Gestalt
  132.     tst.w    d0
  133.     bne    .getdic    ; Error - assume AppleEvents not 
  134.             ;  available.
  135.     move.l    a0,d0
  136.     btst    #0,d0    ; AppleEvents available?
  137.     sne    AppleEventsQ+3-base(a3)    ;  (Set flag so everyone can tell)
  138.     beq    .getdic    ; If not, do it the old way
  139.  
  140. ; We have AppleEvents!  First we have to set up the dispatch table.
  141.  
  142.     clr.w    -(a7)    ; For return result (OSerr)
  143.     move.l    #'aevt',-(a7)    ; theEventClass = kCoreEventClass
  144.     move.l    #'oapp',-(a7)    ; theAEEventID = kAEOpenApplication
  145.     pea    OpenAppHandler    ; handler = OpenAppHandler
  146.     clr.l    -(a7)    ; handlerRefCon = 0
  147.     clr.w    -(a7)    ; isSysHandler = false
  148.     dc.w    $303C,$091F,$A816    ; AEInstallEventHandler
  149.     tst.w    (a7)+    ; Success?
  150.     bne    .startupErr    ; No - PANIC
  151.  
  152.     clr.w    -(a7)    ; For return result (OSerr)
  153.     move.l    #'aevt',-(a7)    ; theEventClass = kCoreEventClass
  154.     move.l    #'odoc',-(a7)    ; theAEEventID = kAEOpenDocuments
  155.     pea    OpenDocHandler    ; handler = OpenDocHandler
  156.     clr.l    -(a7)    ; handlerRefCon = 0
  157.     clr.w    -(a7)    ; isSysHandler = false
  158.     dc.w    $303C,$091F,$A816    ; AEInstallEventHandler
  159.     tst.w    (a7)+    ; Success?
  160.     bne    .startupErr    ; No - PANIC
  161.  
  162.     clr.w    -(a7)    ; For return result (OSerr)
  163.     move.l    #'aevt',-(a7)    ; theEventClass = kCoreEventClass
  164.     move.l    #'pdoc',-(a7)    ; theAEEventID = kAEPrintDocuments
  165.     pea    PrintDocHandler    ; handler = PrintDocHandler
  166.     clr.l    -(a7)    ; handlerRefCon = 0
  167.     clr.w    -(a7)    ; isSysHandler = false
  168.     dc.w    $303C,$091F,$A816    ; AEInstallEventHandler
  169.     tst.w    (a7)+    ; Success?
  170.     bne    .startupErr    ; No - PANIC
  171.  
  172.     clr.w    -(a7)    ; For return result (OSerr)
  173.     move.l    #'aevt',-(a7)    ; theEventClass = kCoreEventClass
  174.     move.l    #'quit',-(a7)    ; theAEEventID = kAEQuitApplication
  175.     pea    QuitAppHandler    ; handler = QuitAppHandler
  176.     clr.l    -(a7)    ; handlerRefCon = 0
  177.     clr.w    -(a7)    ; isSysHandler = false
  178.     dc.w    $303C,$091F,$A816    ; AEInstallEventHandler
  179.     tst.w    (a7)+    ; Success?
  180.     bne    .startupErr    ; No - PANIC
  181.  
  182.     st    ExpDicq-base(a3)    ; Yes.  Set flag to show we're expecting
  183.             ;  an Open Documents AppleEvent to read
  184.             ;  in a dictionary image shortly.
  185. ; &&&    exg    a6,a7
  186.  
  187. ; Now we read in the dictionary, if any.  If AppleEvents are available,
  188. ; there ought to be an AppleEvent coming up for this.  Otherwise we have
  189. ; to keep doing it the old way.
  190.  
  191. .getdic    tst.b    instldq+3-base(a3)    ; Is this an installed application?
  192.     bne    .installed    ; Yes - skip this section
  193.     tst.b    AppleEventsQ+3-base(a3)    ; Do we have AppleEvents?
  194.     bne    .haveAEs    ; Yes
  195.  
  196. ; Code to read the dictionary under systems prior to system 7.
  197.  
  198. .old    moveq    #2,d0
  199.     move.l    $10(a5),d0
  200.     beq    .noRead    ; If no Finder info, skip this
  201.     move.l    d0,a0
  202.     move.l    (a0),a0
  203.     tst    (a0)
  204.     bne    .noRead
  205.     moveq    #1,d0
  206.     tst    2(a0)
  207.     beq    .noRead
  208.     moveq    #3,d0
  209.     add.l    #4,a0
  210.     move.l    2(a0),a1
  211.     cmp.l    #'COM ',A1
  212.     bne    .noRead
  213.  
  214.     move.l    fFcb,a1
  215.     lea    8(a0),a2
  216.     move.l    a2,$12(a1)    ; ioNamePtr
  217.     move.l    a0,a2
  218.     move    (a2),$16(a1)    ; ioVRefNum
  219.     move.b    #1,$1B(a1)    ; ioPermssn
  220.     move.l    a1,a0
  221.     _Open        ; (A0|IOPB:ParmBlkPtr):D0\OSErr
  222.     bne    .noRead    ; If error
  223.  
  224.     exg    a6,a7
  225.  
  226.     st    ExpDicq-base(a3)    ; ReadDic requires A6/7 the "Mops" way round
  227.     bsr    ReadDic
  228.     addq    #4,a6    ; If read error, ignore it!
  229.     bsr    initFW    ; Initialize fWind
  230.     bra.s    .hand    ; Continue with Handlers initialization
  231.  
  232. .noRead    exg    a6,a7    ; We come here if no dic under sys 6.
  233.             ; Get regs the "Mops" way round.
  234.     bsr    initFW    ; Initialize fWind
  235.     bsr    onlyNucMsg    ; Display warning msg
  236.     bra.s    .hand    ; Continue with Handlers initialization
  237.  
  238. ; We come here if we have AppleEvents, so the dic, if any, will be coming later.
  239. ; We don't initialize fWind until then.  A6/7 are the "system" way around.
  240.  
  241. .haveAEs    exg    a6,a7    ; Now the "Mops" way around
  242.     bra.s    .hand    ; initialize Handlers
  243.  
  244. ; We come here if this is an installed application.  A6 and A7 are the "system" way
  245. ; around.
  246.  
  247. .installed    exg    a6,a7    ; Now the "Mops" way around
  248.     bsr    initFW    ; Initialize fWind, if necessary
  249.     move.b    inclHndlrsq,d0    ; Handlers included?
  250.     beq.s    .initlzd    ; no
  251.  
  252. .hand    bsr    initHandlers    ; initialize Handlers
  253.  
  254. ; Now we've done all the system calls associated with initialization, we
  255. ; can do the final setting up, and commence normal execution by calling QUIT.
  256.  
  257. .initlzd    moveq    #-1,d0    ; A2 doesn't point to an object yet
  258.     move.l    d0,a2    ;  -- force trap if it's used
  259.     move.l    d0,a5    ; -1 in modbase means no mod
  260.     lea    myRegs,a0
  261.     movem.l    a3-a5/a7,(a0)    ; Save our regs for :PROC
  262.  
  263.  
  264. ; **** This next part may not work on all future Macs - be careful!! ****
  265.  
  266. ; First we save 28 bytes from location zero, since we're going to clobber some
  267. ; of the locations.  Then at BYE we'll restore them.  I just save and restore
  268. ; the same block no matter what I do in low mem, since it's easier that way
  269. ; and less likely to introduce bugs.
  270.  
  271. ; Note: we're not handling bus errors any more. System 7 virtual memory
  272. ; needs them!!!
  273.  
  274.     movem.l    $0,d0-d6
  275.     lea    saveLM,a0
  276.     movem.l    d0-d6,(a0)
  277.  
  278.     lea    CHKfailed,a0
  279.     move.l    a0,$18    ; Set CHK exception vector
  280.     tst.b    instldq+3-base(a3)
  281.     bne.s    .exec    ; Only do the next bit if this isn't
  282.             ;  an installed application
  283.     move.l    JmpAbort,$1E4    ; Set a jump to ABORT in scratch20 area
  284.             ; so we can easily call ABORT from 
  285.             ; Macsbug
  286.  
  287. ; **** End of dubious section!! ****
  288.  
  289. ; Now we start execution:
  290.  
  291. .exec    tst.b    expDicq-base(a3)    ; Are we still waiting for a dic?
  292.     bne.s    .quit    ; Yes - skip this.  We'll have to wait
  293.             ;  till the dic comes in.
  294.     exVect    objinit    ; No. Initialize system objects now.
  295.  
  296. .quit    jsr    quit-base(A3)    ; Go to it!!
  297.  
  298. ;    ==========================
  299.  
  300. JmpAbort
  301.     JMP    abort-base(A3)
  302.  
  303. ; We come here if something goes wrong!
  304.  
  305. .startupErr
  306.     move.w    #3,-(a7)
  307.     _SysBeep
  308.     move.w    #3,-(a7)
  309.     _SysBeep
  310.     move.w    #3,-(a7)
  311.     _SysBeep
  312.     _ExitToShell
  313.  
  314.  
  315. SaveLM    long    7    ; Saves some low memory locations
  316.             ;  we modify.  Restored at BYE.
  317.  
  318. ; INITFW initializes the default window fWind.
  319.  
  320.     loc
  321. initFW    tst.b    fWindq+3-base(a3)    ; Don't set up fWind if it's not requested
  322.     beq.s    .out
  323.  
  324.     savA5
  325.     clr.l    -(a7)
  326.     move    #256,-(sp)
  327.     pea    fWind
  328.     moveq    #-1,d0
  329.     move.l    d0,-(sp)
  330.     _GetNewWindow    ; (windowID:INTEGER; wStorage:Ptr;
  331.             ;  behind:WindowPtr): WindowPtr
  332.     _SetPort        ; (port:GrafPtr)
  333.     LEA    fWind,A0
  334.     MOVE    #9,74(A0)    ; Point size = 9
  335.     MOVE    #4,68(A0)    ; Font = Monaco
  336.  
  337.     lea    fWind+156,a1    ; Now set fWind's contRect in case not done
  338.     move.l    16(a0),(a1)+
  339.     move.l    20(a0),(a1)+
  340.  
  341.     LEA    FpRect,A1
  342.     MOVE.L    16(A0),(A1)
  343.     MOVE.L    20(A0),4(A1)
  344. ;    CLR.L    -(SP)
  345. ;    _NewRgn        ; :RgnHandle
  346. ;    MOVE.L    (SP)+,TheRgn-base(A3)
  347.     CLR    -(SP)
  348.     _TextMode    ; (mode:INTEGER{|XferMode})
  349.     rstA5
  350.     jsr    CR-base(a3)    ; Do CR so top line is visible
  351.     st    emitq+3-base(a3)    ; EMIT etc. can now be done since a
  352.             ;  window exists
  353.  
  354. .out    rts
  355.  
  356.  
  357. ;        =============================
  358.  
  359. ;        HANDLERS FOR CORE APPLEEVENTS
  360.  
  361. ;        =============================
  362.  
  363. ; These have to be available in the nucleus, so that the nucleus can be properly
  364. ; System 7 friendly.  We have provided vectors so that applications may customize
  365. ; the handling of these AppleEvents.  Each of these vectors has stack effect
  366. ; ( -- code True  |  -- False ). 
  367. ; If False is returned, the default handler windup is used, which performs
  368. ; the recommended calls to check if we got all the parameters and return the
  369. ; appropriate error if not.
  370. ; If True is returned, we assume that the event has been fully handled within
  371. ; the vector routine, and so we return straight to the caller - the code is the
  372. ; result code that gets passed back.
  373. ; The default for these vectors assumes that the Mops development environment
  374. ; is running, and does the appropriate things. 
  375.  
  376.  
  377. saveAbortVec    long
  378. saveQuitVec        long
  379. saveA6        long
  380. ReadErr        byte
  381.         align
  382.  
  383. doAEhandler        ; Called from AEhandler to set things up at the
  384.         ; start of a handler.
  385.         ; ( ^AE ^AEReply RefCon -- )
  386.  
  387.     pop.l    AERefCon-base(a3)
  388.     pop.l    AEReply-base(a3)
  389.     pop.l    fAE-base(a3)
  390.     lea    saveAbortVec,a0
  391.     move.l    abortVec+4,(a0)    ; -> saveAbortVec
  392.     move.l    quitVec+4,4(a0)    ; -> saveQuitVec
  393.     move.l    a6,8(a0)    ; -> saveA6
  394.     sf    DicRead-base(a3)    ; Clear DicRead - will be set if we read
  395.             ;   a dic, so we don't restore abortVec
  396.             ;   and quitVec.
  397.     setVect    .abErr,abortVec
  398.     setVect    .quitErr,quitVec
  399.     rts
  400.  
  401. .abErr
  402.     moveq    #60,d0    ; "AppleEvent handler aborted"
  403.     bra.s    .qe1
  404.  
  405. .quitErr
  406.     moveq    #61,d0    ; "AppleEvent handler quitted"
  407. .qe1    move.l    d0,pErrNum-base(a3)
  408.     clr.l    -(a6)    ; Return False for default windup
  409.     bra.s    hndlrWindup
  410.  
  411.  
  412. OpenAppHandler
  413.     move.l    saveEP,A0    ; Normal :PROC entry sequence to set up
  414.     jsr    (a0)    ;  the Mops addressing environment
  415.     bsr    doAEhandler    ; Pop the parms to where we want them
  416.     exVect    OpenAppVec
  417.  
  418. hndlrWindup            ; Common handler windup.
  419.     move.b    DicRead,d0    ; If we just read a dic, QuitVec and AbortVec
  420.     bne.s    .hw1    ; will have been set, so we skip restoring
  421.             ; them.
  422.     move.l    saveAbortVec,abortVec+4-base(a3)
  423.     move.l    saveQuitVec,quitVec+4-base(a3)
  424. .hw1    pop.l    d0    ; Get returned result from handler
  425.     bne    ProcExit    ; True - assume everything OK to return
  426.             ;  to system.
  427.  
  428.             ; False - we do the default windup:
  429.     move.l    saveA6,A6    ; Restore data stk ptr just in case.
  430.     bsr    GotParmsq
  431.     bsr    qRtnAEPmissed
  432.     bra    ProcExit
  433.  
  434.  
  435. OpenDocHandler
  436.     move.l    saveEP,A0    ; Normal :PROC entry sequence to set up
  437.     jsr    (a0)    ;  the Mops addressing environment
  438.     bsr    doAEhandler    ; Pop the parms to where we want them
  439.     exVect    OpenDocVec    ; OpenDocVec does the work
  440.     bra.s    hndlrWindup
  441.  
  442.  
  443. PrintDocHandler
  444.     move.l    saveEP,A0    ; Normal :PROC entry sequence to set up
  445.     jsr    (a0)    ;  the Mops addressing environment
  446.     bsr    doAEhandler    ; Pop the parms to where we want them
  447.     exVect    PrintDocVec    ; PrintDocVec does the work
  448.     bra    HndlrWindup
  449.  
  450.  
  451. QuitAppHandler
  452.     move.l    saveEP,A0    ; Normal :PROC entry sequence to set up
  453.     jsr    (a0)    ;  the Mops addressing environment
  454.     bsr    doAEhandler    ; Pop the parms to where we want them
  455.     st    QuitAppq-base(a3)    ; Set flag to show we've been requested
  456.             ;  to quit.  We don't have a vector for this
  457.             ;  one, since we're not allowed to quit from
  458.             ;  an AppleEvent handler (penalty: a CRASH).
  459.     bra    HndlrWindup
  460.  
  461. ;    =============================
  462.  
  463. ; OpenMopsDic is the default for OpenDocVec.
  464.  
  465. OpenMopsDic
  466.     savA5
  467.  
  468. ; First we get the direct parameter - a list of descriptors - into docList.
  469.  
  470.     clr.w    -(a7)    ; For return OSerr result
  471.     move.l    fAE,-(a7)    ; theAppleEvent = fAE
  472.     move.l    #'----',-(a7)    ; theAEkeyword  = keyDirectObject
  473.     move.l    #'list',-(a7)    ; desiredType   = typeAEList
  474.     pea    docList    ; result        = docList
  475.     
  476.     dc.w    $303C, $0812, $A816    ; call AEGetParamDesc
  477.  
  478.     move.w    (a7)+,d0
  479.     bne    .ODHerr
  480.  
  481. ; Now we count the items in docList.
  482.  
  483.     clr.w    -(a7)
  484.     pea    docList    ; theAEDescList = docList
  485.     pea    NumDocsToOpen    ; theCount      = #docsToOpen
  486.  
  487.     dc.w    $303C, $0407, $A816    ; call AECountItems
  488.  
  489.     move.w    (a7)+,d0
  490.     bne    .ODHerr1
  491.  
  492.     moveq    #1,d0
  493.     lea    itemindex,a0
  494.     move.l    d0,(a0)    ; Initial index = 1
  495.     bra.s    .omdlp1
  496.  
  497. ; Loop to get the next descriptor from the list:
  498.  
  499. .omdLoop
  500.     savA5
  501. .omdlp1    clr.w    -(a7)    ; For OSerr result
  502.     pea    docList    ; theAEDescList = docList
  503.     move.l    itemindex,-(a7)    ; index = itemindex
  504.     move.l    #'fss ',-(a7)    ; desiredType = typeFSS
  505.     pea    keywd    ; theAEKeyword = keywd
  506.     pea    typeCode    ; typeCode = typeCode
  507.     move.l    fFcb,a2
  508.     lea    FCBlen-64-6(a2),a2    ; dataPtr = addr of FSSpec record in fFcb
  509.     move.l    a2,-(a7)
  510.     move.l    #70,-(a7)    ; maximumSize = (size of fileSpec)
  511.     pea    actualSize    ; actualSize = actualSize
  512.  
  513.     dc.w    $303C, $100A, $A816    ; call AEGetNthPtr
  514.  
  515.     move.w    (a7)+,d0
  516.     bne    .ODHerr1
  517.     move.l    fFcb,d0
  518.  
  519. ; Now we open the file.
  520.  
  521.     clr.w    -(a7)    ; For OSerr result
  522.     move.l    a2,-(a7)    ; spec = FSSpec record in fFcb
  523. ;    move.w    #1,-(a7)    ; permission = read only
  524.     clr.w    -(a7)    ; permission = read/write
  525.     pea    refNum    ; refNum = refNum
  526.     dc.w    $303C, $0002, $AA52    ; call FSpOpenDF
  527.     move.w    (a7)+,d0
  528.     bne    .ODHerr1
  529.  
  530.     move.l    fFcb,a1
  531.     lea    6(a2),a0
  532.     move.l    a0,$12(a1)    ; Name pointer
  533.     move.l    2(a2),48(a1)    ; ioDirID
  534.     move.w    refNum,24(a1)    ; file ref num
  535.     move.w    (a2),$16(a1)    ; vRefNum
  536. ;    move.b    #1,$1B(a1)    ; ioPermssn
  537.  
  538.     rstA5
  539.     jsr    Read1DocVec-base(a3)    ; Read in the document (dic or whatever)
  540.             ; Note: result on stack is false if loop
  541.             ;  is not to be continued.
  542.  
  543. ; If this isn't an installed application, that was a dictionary we read in.
  544. ; In this case we initialize fWind, then call ObjInit to initialize objects etc.
  545. ; We couldn't do this before, as the vectors were probably set to
  546. ; locations in the dic above the nucleus, and the dic wasn't in yet!  Note we
  547. ; don't actually call objinit and extraInits here, since we're in an AE handler,
  548. ; but by clearing expDicq we ensure we call them when we get back to the normal
  549. ; Mops environment.  (Calling them worked OK here, but the stack depth looked
  550. ; strange, and I'm a bit suspicious about doing too much in a callback routine anyway.)
  551.  
  552.     tst.b    instldq+3-base(a3)
  553.     bne.s    .omdLpTst
  554.  
  555.     move.b    ReadErr,d0    ; It's a Mops dictionary.
  556.     bne.s    .omdLpTst    ; Skip initialization if error reading dic
  557.     move.l    pErrNum,d0
  558.     bne.s    .ODHerr2    ; Or if a Mops error was raised (terminate
  559.             ;  the loop in this case)
  560.  
  561.     bsr    initFW    ; All OK.  Initialize fWind
  562.  
  563. .omdLpTst
  564.     pop.l    d0    ; Look at result from Read1DocVec
  565.     beq.s    .ODHerr2    ; Skip next part if not to continue loop
  566.  
  567.     lea    itemindex,a0
  568.     move.l    (a0),d0    ; itemindex to D0
  569.     addq.l    #1,(a0)
  570.     cmp.l    NumDocsToOpen-base(a3),d0
  571.     blt    .omdLoop    ; Loop if index still less than count
  572.  
  573. ; That's it.  Now we clean up.  We also come here on any errors, once
  574. ; AEGetParamDesc has been called, to dispose of the descriptor copy.  On any
  575. ; errors before that, we go to .ODHerr.  We enter at .ODHerr1 if savA5 has
  576. ; already been done.
  577.  
  578. .ODHerr2
  579.     savA5
  580. .ODHerr1
  581.     clr.w    -(a7)    ; For OSerr result
  582.     pea    docList    ; theAEDesc = docList
  583.     dc.w    $303C, $0204, $A816    ; call AEDisposeDesc
  584.     move.w    (a7)+,d0
  585.     
  586. .ODHerr    rstA5
  587.     clr.l    -(a6)    ; Return False for default windup
  588.     rts
  589.  
  590. ; OpenWithoutDic is the default for OpenAppVec.  It's called if the Mops appl
  591. ; is opened without a dictionary.  If this isn't an installed application, we
  592. ; initialize fWind, then call ObjInit to initialize objects etc.  We
  593. ; had to wait to see if a dic was coming in before we could do this (see comments
  594. ; above). 
  595.  
  596. OpenWithoutDic
  597.     tst.b    instldq+3-base(a3)
  598.     bne.s    .owdOut
  599.  
  600.     bsr    initFW    ; Initialize fWind
  601.     sf    expDicq-base(a3)    ; Clear expDicq so objInit will be called
  602.     bsr    onlyNucMsg    ; Display warning msg
  603.  
  604. .owdOut    clr.l    -(a6)    ; Return False for default windup
  605.     rts
  606.  
  607.  
  608. docList    long    2
  609. ignoreDesc    long
  610. itemindex    long
  611. keywd    long
  612. typeCode    long
  613. actualSize    long
  614. refNum    long
  615.  
  616. onlyNucMsg    msg    This is only the nucleus.  To begin loading the full system/$2C type
  617.     bsr    cr
  618.     msg    load base <ENTER>
  619.     bsr    cr
  620.     msg    (see the Readme.1st file/$2C or the intro chapter of the manual).
  621.     bsr    cr
  622.     rts
  623.  
  624. ;    =========================
  625.  
  626. ; ReadDic reads in a dictionary image.  Entered with A1 -> FCB.  File must
  627. ; already be open.  A6 and A7 are as for normal Mops execution.
  628.  
  629. ; First we have to do some checks.
  630. ; 1.  Have we already got a dictionary?
  631.  
  632. ReadDic    move.l    a1,a0
  633.     savA5
  634.     move.l    a0,a1
  635.     tst.b    ExpDicq-base(a3)    ; Have we got a dic already
  636.     bne.s    .rd1    ; No
  637.     moveq    #104,d0    ; Yes - signal error 104
  638.     move.l    d0,pErrNum-base(a3)
  639.     _Close
  640.     bra    .rdOut
  641.  
  642. ; 2. Is this really a dictionary?  If so, it will start with the cfa of LATEST.
  643. ; That takes 4 bytes.  Then there's the lfa of CURR-DEF (4 bytes).  Then, at
  644. ; offset 8, comes the name field of CURR-DEF.  This starts with $88435552.
  645. ; That's as good a check for a valid dictionary as any!
  646.  
  647. .rd1    lea    testRead,a2    ; 
  648.     move.l    a2,$20(a0)    ; ioBuffer
  649.     moveq    #4,d1
  650.     move.l    d1,$24(a0)    ; ioReqCount = 4
  651.     move.w    #1,$2C(a0)    ; ioPosMode = absolute
  652.     moveq    #8,d0
  653.     move.l    d0,$2E(a0)    ; ioPosOffset = 4
  654.     _Read        ; (A0|IOPB:ParmBlkPtr):D0\OSErr
  655.     moveq    #100,d1
  656.     tst.w    d0
  657.     bne.s    .rdFail
  658.  
  659.     moveq    #101,d1
  660.     move.l    testRead,d0
  661.     cmp.l    #$88435552,d0
  662.     bne.s    .rdFail
  663.  
  664.     lea    latest,a2    ; A2 -> where we start reading into
  665.     move.l    dicSize,d1    ; D1 = max possible size of dic to be read
  666.     sub.l    #latest-start,d1    ; Actual dic file length must be less.
  667.     move.l    a2,$20(a0)    ; ioBuffer
  668.     move.l    d1,$24(a0)    ; ioReqCount
  669.     move.w    #1,$2C(a0)    ; ioPosMode = absolute
  670.     clr.l    $2E(a0)    ; ioPosOffset = 0
  671.     _Read        ; (A0|IOPB:ParmBlkPtr):D0\OSErr
  672.  
  673.     moveq    #100,d1
  674.     cmp.w    #-39,d0    ; We should have got eofErr on the read
  675.     bne.s    .rdFail    ; If not, give error alert and quit
  676.  
  677.     sf    ExpDicq-base(a3)    ; We got the dic, so we don't want it again
  678.     st    DicRead-base(a3)
  679.     movea.l    a1,a0
  680.     _Close    ; (A0|IOPB:ParmBlkPtr):D0\OSErr
  681.     lea    dp,a0
  682.     move.l    a0,d0
  683.     add.l    d0,dp-base(a3)
  684.     add.l    d0,latest-base(a3)
  685.  
  686. .rdOut    rstA5
  687.     moveq    #-1,d0    ; In all cases we return True - OpenDoc loop
  688.     push.l    d0    ;  can continue.  If more than one dic,
  689.     rts        ;  error 104 will come up.
  690.  
  691. .rdFail    move.w    d1,-(a7)
  692.     clr.l    -(a7)
  693.     _StopAlert
  694.     _ExitToShell
  695.  
  696. testRead    ds.b    4
  697.  
  698. ;    ==========================
  699.  
  700. ; InitHandlers initializes the Handlers package, by passing it the address
  701. ; of all the locations in this segment that it may need.  Note that
  702. ; A6 and A7 are still exchanged, as the initial call to an unloaded
  703. ; segment seems to clobber wherever A6 points.
  704.  
  705. InitHandlers
  706.     exg    a6,a7    ; So we can use PEAs
  707.     PEA    dp
  708.     PEA    fmkCnt
  709.     PEA    callOut
  710.     PEA    CCmpFlg
  711.     pea    colaFlg
  712.     PEA    optq
  713.     PEA    methodq
  714.     PEA    numPL
  715.     PEA    numP
  716.     pea    numF
  717.     PEA    FltFlg
  718.     PEA    locNo
  719.     PEA    localq
  720.     pea    frameSize
  721.     pea    relTmps
  722.     pea    numLast
  723.     PEA    modEntry
  724.     PEA    cmp_h
  725.     PEA    xJsrToVect
  726.     PEA    xAtAbs
  727.     PEA    xMulX
  728.     PEA    xPushBool
  729.     PEA    MBcomp
  730.     PEA    SAcomp
  731.     PEA    HWPavail+3
  732.     PEA    state
  733.     PEA    UseFPUq
  734.     pea    ptrFPdisp
  735.     pea    ptrFPdisp2
  736.     pea    ptrFPnew
  737.     pea    ptrFPULit
  738.     PEA    ptrLfloat
  739.     PEA    ptrToLfloat
  740.     PEA    ptrToFval
  741.     PEA    ptrLFdisp
  742.     pea    ExtraLocals
  743.     pea    heldMod
  744.     pea    EBmod
  745.     pea    MethIndex
  746.     pea    inhibitMBq
  747.     pea    Lshift
  748.     pea    ARshift
  749.     pea    moveLs
  750.     pea    moveBs
  751.     pea    callBM
  752.     pea    xSysCall
  753.  
  754.     exg    a6,a7
  755.     MOVEQ    #0,D0
  756.     callh
  757.     MOVE.L    A1,ODaddr-base(A3)
  758. .getout
  759. dummy    RTS
  760.  
  761.  
  762. ; CallHandlers is the glue routine to call Handlers, invoked by the macros
  763. ; callh and jumph.  Entered with the handlers selector in D0.
  764. ; We have to do it this way as A5 needs to be set back to where the system expects
  765. ; it before we can call another segment, since the jump table is addressed off A5.
  766.  
  767.  
  768. CallHandlers
  769.     tst.b    PPCq+3-base(a3)    ; if we're compiling for PPC, we don't
  770.             ;  call Handlers at all.  comp4ppc will
  771.     bne    comp4ppc    ;  look after it.
  772.  
  773.     move.l    A5,D1    ; Save our A5 - handlers will look after it
  774.     move.l    CurrentA5,A5
  775.     jsr    Handlers
  776.     tst.l    D0    ; Did Handlers report an error?
  777.             ;  (initial entry won't.  Definitely.
  778.             ;   Absolutely.  For sure.  I hope.)
  779.     beq.s    .rtn    ; No: get out
  780.     push.l    D0    ; Yes: push err#
  781.     jmp    die-base(A3)    ; and die (forward)
  782. .rtn    rts
  783.  
  784.  
  785. ;    =======================================
  786.  
  787. ; Following are miscellaneous items and chunks of code that we have put here
  788. ; below the LoBase addressing range, to allow as much addressing headroom as
  789. ; possible.  All names of the form doXXX are BRA'd to from the word XXX in the
  790. ; main dictionary.
  791.  
  792. ;    =======================================
  793.  
  794. doTraverse    pop.l    d0
  795.     pop.l    a0
  796.     moveq    #32,d2
  797.     tst.l    d0
  798.     bmi.s    .down
  799.     move.b    (a0),d0
  800.     moveq    #$1F,d1
  801.     and.l    d1,d0
  802.     add.l    d0,a0
  803.     move.l    a0,d0
  804.     moveq    #1,d1
  805.     and.l    d1,d0
  806.     sub.l    d0,a0
  807.     addq.l    #1,a0
  808.     bra.s    .end
  809.  
  810. .down    tst.b   -(a0)
  811.     dbmi    d2,.down
  812.  
  813. .end    push.l    a0
  814.     rts
  815.  
  816.     loc
  817. doBye    move.l    CurrentA5,A5
  818.     movem.l    SaveLM,d0-d6
  819.     movem.l    d0-d6,$0
  820.     _ExitToShell
  821.  
  822. doCount
  823.     MOVE.L    (A6),A0
  824.     ADDQ.L    #1,(A6)
  825.     MOVEQ    #0,D0
  826.     MOVE.B    (A0),D0
  827.     PUSH.L    D0
  828.     RTS
  829.  
  830. doLength
  831.     MOVE.L    (A6),A0
  832.     ADDQ.L    #2,(A6)
  833.     MOVEQ    #0,D0
  834.     MOVE.W    (A0),D0
  835.     PUSH.L    D0
  836.     RTS
  837.  
  838. doDepth
  839.     MOVE.L    sp0,D0
  840.     SUB.L    A6,D0
  841.     ASR.L    #2,D0
  842.     PUSH.L    D0
  843.     RTS
  844.  
  845. doDigit    loc
  846.     pop.l    d0    ; D0 = number base
  847.     pop.l    d1    ; D1 = char for checking
  848.     moveq    #0,D2    ; Guilty until proven innocent
  849.     cmp.b    #'a',d1
  850.     blo.s    .dig1
  851.     cmp.b    #'z',d1
  852.     bhi.s    .end    ; if above lower-case letters, fail
  853.     and.b    #$DF,d1    ; convert LC letter to UC
  854.  
  855. .dig1    sub.b    #$30,D1    ; '0'-'9' -> 0-9
  856.     bmi.s    .end    ; if less than 0, not a digit
  857.     cmp.b    #10,D1
  858.     bmi.s    .cmp    ; less than 9 - check it against the base
  859.     subq.b    #7,D1    ; bring A-Z down to 10-35
  860.     cmp.b    #10,D1    ; 
  861.     bmi.s    .end
  862. .cmp    cmp.b    D0,D1
  863.     bge.s    .end
  864.     moveq    #0,d0    ; Success
  865.     move.b    d1,d0
  866.     moveq    #-1,D2
  867.     push.l    D0
  868. .end    push.l    D2
  869.     rts
  870.  
  871. doWatIP
  872.     MOVE.L    4(A7),A0
  873.     MOVEQ    #0,D0
  874.     MOVE.W    (A0)+,D0
  875.     PUSH.L    D0
  876.     MOVE.L    A0,4(A7)
  877.     RTS
  878.  
  879. doAtIP
  880.     MOVE.L    4(A7),A0
  881.     MOVE.L    (A0)+,-(A6)
  882.     MOVE.L    A0,4(A7)
  883.     RTS
  884.  
  885. ; pHash is the routine to hash the counted string pointed to by A0.
  886. ; The result goes to D0.  Uses D2, changes A0.
  887.  
  888.     loc
  889. pHash    move.l    (a6),a0
  890.     moveq    #0,d0    ; Result will go to D0
  891.     moveq    #0,d2
  892.     move.b    (a0)+,d2    ; Count
  893.     and.b    #$7F,d2    ; Clear top bit in case it's a name field
  894.     bra.s    .lptest
  895.  
  896. .loop    rol.l    #7,d0
  897.     move.b    (a0)+,d1
  898.     eor.b    d1,d0
  899. .lptest    dbra    d2,.loop
  900.     rts
  901.  
  902. doHash
  903.     bsr.s    phash
  904.     tst.l    d0
  905.     bmi.s    .out
  906.     not.l    d0
  907. .out    move.l    d0,(a6)
  908.     rts
  909.  
  910. doWhash
  911.     loc
  912.     bsr.s    phash
  913.     MOVEQ    #0,D1
  914.     MOVE.W    D0,D1
  915.     SWAP    D0
  916.     EOR.W    D0,D1
  917.     MOVE.L    D1,(A6)
  918.     RTS
  919.  
  920.  
  921. ; xPushBool may be compiled after an operation that sets the CCR,
  922. ; to convert an EQ/NE indication to a boolean flag on the stack.
  923. ; We use it in handling BTEST in some situations.
  924.  
  925. xPushBool
  926.     jsr    pushBool-base(A3)
  927.  
  928. ; xMulX is for use in inline code generated by Handlers.
  929.  
  930. xMulX    jsr    MulX-base(a3)
  931.  
  932. ; xAtAbs is compiled in inline calls to exec: x-array.
  933.  
  934. xAtAbs    jsr    pAtAbs-base(a3)
  935.  
  936. ; xSysCall is compiled by SysCall - it comes at the start of the code sequence to
  937. ;  do a system call.
  938.  
  939. xSysCall    jsr    pSysCall-base(a3)
  940.  
  941.  
  942. ; The following locations are used by :PROC to save the system's registers
  943. ; These can be below the LoBase range since we access them with PC-relative
  944. ; addressing.
  945.  
  946. sysRegs    long    12    ; Saves system's D2-D7 and A1-A6
  947.  
  948.  
  949. doPSysCall    loc
  950.     move.l    (a7),a0
  951.     moveq    #0,d1
  952.     move.b    (a0)+,d1    ; Get number of parms to D1
  953.     move.l    d1,d0
  954.     add.l    d0,d0
  955.     add.l    d0,d0    ; and # bytes to D0
  956.     add.l    d0,a6    ; A6 -> base of parms for loop
  957.     move.l    a6,d2    ; also save in D2
  958.     move.l    a6,a1    ; and to A1 for source addr in loop
  959.     bra.s    .loopTst
  960.  
  961. .parmLoop    move.b    (a0)+,d0    ; get next parm info byte
  962.     cmp.b    #4,d0
  963.     bne.s    .short    ; if not 4-byte parm
  964.     move.l    -(a1),-(a6)    ; 4 - copy parm
  965.     bra.s    .loopTst
  966.  
  967. .short    cmp.b    #2,d0    ; short - is it 2 bytes or 1?
  968.     beq.s    .2bytes
  969.     move.l    -(a1),d0    ; 1 - grab 4-byte parm.  2 to be pushed,
  970.     lsl.w    #8,d0    ; with the parm in the leftmost.
  971.     bra.s    .pushW
  972.  
  973. .2bytes    move.l    -(a1),d0    ; 2 - just grab 4-byte parm
  974.  
  975. .pushW    move.w    d0,-(a6)    ; and push as 2-byte
  976.  
  977. .loopTst    dbra    d1,.parmLoop
  978.  
  979. .chkResult    moveq    #0,d1
  980.     move.b    (a0)+,d1    ; # result bytes to D1
  981.     move.l    a0,d0    ; align parm info addr - this will
  982.     addq.l    #1,d0    ;  be the start of the inline code
  983.     and.l    #-2,d0    ;  to execute for the call
  984.     move.l    d0,(a7)    ; Replace as return addr
  985.     tst.l    d1
  986.     beq.s    .done    ; If no result, we're done
  987.  
  988.     move.l    a6,a0    ; Set up to move parms down to make
  989.     subq.l    #4,a6    ;  room for result - we always need
  990.             ;  a full cell, and adjust at the end
  991.     sub.l    a0,d2    ; # bytes in parm block to D2
  992.     asr.l    #1,d2    ; div by 2 for loop
  993.     move.l    a6,a1
  994.     bra.s    .rsltLpTst
  995.  
  996. .rsltLoop    move.w    (a0)+,(a1)+    ; move parms down
  997. .rsltLpTst    dbra    d2,.rsltLoop
  998.  
  999. .done    bra    doSavA5    ; set up regs for call, then exit to
  1000.             ;  inline code
  1001.  
  1002.  
  1003. doNewP    ; ( n -- b )  Called from NEWP, in nuc2.asm
  1004.     MOVE.L    (A6),D0
  1005.     EXG    A6,A7
  1006.     _NewPtr    ; (D0/byteCount:Size):A0\Ptr 
  1007.     EXG    A6,A7
  1008.     BNE.S    .failed
  1009.     MOVE.L    A0,(A2)
  1010.     MOVEQ    #-1,D0
  1011.     MOVE.L    D0,(A6)
  1012.     RTS
  1013.  
  1014. .failed    ExVect    getspace
  1015.     TST.L    (A6)+
  1016.     BNE.S    doNewP
  1017.     MOVE.L    nilP,(A2)
  1018.     CLR.L    (A6)
  1019.     RTS
  1020.  
  1021.     loc
  1022. doNewH    ; ( n -- b )  Called from Nuc2.asm
  1023.     MOVE.L    (A6),D0
  1024.     EXG    A6,A7
  1025.     _NewHandle    ; (D0/byteCount:Size):A0\Handle 
  1026.     EXG    A6,A7
  1027.     BNE.S    .failed
  1028.     MOVE.L    A0,(A2)
  1029.     MOVEQ    #-1,D0
  1030.     MOVE.L    D0,(A6)
  1031.     RTS
  1032.  
  1033. .failed    ExVect    getspace
  1034.     TST.L    (A6)+
  1035.     BNE.S    doNewH
  1036.     MOVE.L    nilH,(A2)
  1037.     CLR.L    (A6)
  1038.     RTS
  1039.  
  1040. doLok    move.l    (a2),a0
  1041.     TST.L    (A0)    ; Force trap if nil
  1042.     EXG    A6,A7
  1043.     _HLock    ; (A0/h:Handle)
  1044.     EXG    A6,A7
  1045.     RTS
  1046.  
  1047. doUnlok    move.l    (a2),a0
  1048.     move.l    nilH,d1
  1049.     cmp.l    d1,a0
  1050.     beq.s    .out
  1051.     exg    a6,a7
  1052.     _HUnlock    ; (A0/h:Handle)
  1053.     exg    a6,a7
  1054. .out    rts
  1055.  
  1056. doHgetst    move.l    (a2),a0
  1057.     tst.l    (a0)
  1058.     exg    a6,a7
  1059.     _HGetState
  1060.     exg    a6,a7
  1061.     push.l    d0
  1062.     rts
  1063.  
  1064. doHsetst    pop.l    d0
  1065.     move.l    (a2),a0
  1066.     tst.l    (a0)
  1067.     exg    a6,a7
  1068.     _HSetState
  1069.     exg    a6,a7
  1070.     rts
  1071.  
  1072. doMvHhi    move.l    (a2),a0
  1073.     tst.l    (a0)
  1074.     exg    a6,a7
  1075.     _MoveHHi
  1076.     exg    a6,a7
  1077.     ext.l    d0
  1078.     push.l    d0
  1079.     rts
  1080.  
  1081. doKillP    move.l    (a2),a0
  1082.     move.l    nilP,d1
  1083.     cmp.l    d1,a0
  1084.     beq.s    kpout
  1085.     exg    a6,a7
  1086.     _DisposePtr    ; (A0/p:Ptr) 
  1087. .kp1    exg    a6,a7
  1088.     move.l    d1,(a2)
  1089. kpout    rts
  1090.  
  1091. doKillH    move.l    (a2),a0
  1092.     move.l    nilH,d1
  1093.     cmp.l    d1,a0
  1094.     beq.s    kpout
  1095.     exg    a6,a7
  1096.     _disposehandle    ; (a0/h:handle)
  1097.     bra.s    .kp1
  1098.  
  1099. doCopyH    move.l    (a6),a1    ; Addr of source handle
  1100.     move.l    (a1),a0    ; Source handle to A0
  1101.     exg    a6,a7
  1102.     _HandToHand    ; Get new handle with copy of data
  1103.     exg    a6,a7
  1104.     move.l    a0,(a2)    ; Put new handle in current handle object
  1105.     ext.l    d0    ; Leave result code on stack
  1106.     move.l    d0,(a6)
  1107.     rts
  1108.  
  1109. doGetHsz    move.l    (a2),a0
  1110.     tst.l    (a0)    ; Force trap if nil
  1111.     exg    a6,a7
  1112.     _GetHandleSize
  1113.     exg    a6,a7
  1114.     push.l    d0
  1115.     rts
  1116.  
  1117.     loc
  1118. doSetHsize    ; ( n -- b )  Called from nuc2.asm
  1119.     MOVE.L    (A6),D0
  1120.     MOVE.L    (A2),A0
  1121.     TST.L    (A0)    ; Force trap if nil
  1122.     EXG    A6,A7
  1123.     _SetHandleSize
  1124.     EXG    A6,A7
  1125.     BNE.S    .failed
  1126.     MOVEQ    #-1,D0
  1127.     MOVE.L    D0,(A6)
  1128.     RTS
  1129.  
  1130. .failed    ExVect    getSpace
  1131.     TST.L    (A6)+
  1132.     BNE.S    doSetHsize
  1133.     CLR.L    (A6)    ; Note: on failure, we leave handle unchanged
  1134.     RTS
  1135.  
  1136. doFree    exg    a6,a7
  1137.     _FreeMem
  1138.     exg    a6,a7
  1139.     push.l    d0
  1140.     rts
  1141.  
  1142. doFreeBlk    exg    a6,a7
  1143.     _MaxMem
  1144.     exg    a6,a7
  1145.     push.l    d0
  1146.     rts
  1147.  
  1148. doUnpk
  1149.     MOVE.L    (A6),D0
  1150.     MOVE.W    D0,D1
  1151.     EXT.L    D1
  1152.     MOVE.L    D1,(A6)
  1153.     ASR.L    #8,D0
  1154.     ASR.L    #8,D0
  1155.     PUSH.L    D0
  1156.     RTS
  1157.  
  1158. doQevent
  1159.     loc
  1160.     savA5
  1161.     MOVE.L    (SP)+,D2
  1162.     SWAP    D2
  1163.     MOVE.L    D2,-(SP)
  1164.     PEA    fEvent
  1165.     _EventAvail  ; (mask:EventMask; VAR theEvent:EventRecord):BOOLEAN
  1166.     MOVEQ    #0,D0
  1167.     TST    (SP)+
  1168.     BEQ.S    .end
  1169.     TST    fEvent-base(A3)
  1170.     BEQ.S    .end
  1171.     MOVEQ    #-1,D0
  1172. .end    rstA5
  1173.     PUSH.L    D0
  1174.     RTS
  1175.  
  1176. doPseq    loc
  1177.     POP.L    D0
  1178.     POP.L    A0
  1179.     POP.L    A1
  1180. .pseq1    SUBQ.L    #1,D0
  1181.  
  1182. .loop    CMPM.B    (A0)+,(A1)+
  1183.     DBNE    D0,.loop
  1184.     BEQ.S    .eq
  1185. .noteq    CLR.L    -(A6)
  1186.     RTS
  1187.  
  1188. .eq    MOVEQ    #-1,D0
  1189.     PUSH.L    D0
  1190.     RTS
  1191.  
  1192. doSeq
  1193.     POP.L    D0
  1194.     POP.L    A0
  1195.     POP.L    D1
  1196.     POP.L    A1
  1197.     CMP.W    D0,D1
  1198.     BEQ.S    .pseq1
  1199.     BRA.S    .noteq
  1200.  
  1201. doUpper    loc
  1202.     POP.L    D0
  1203.     POP.L    A0
  1204. upr1    SUBQ    #1,D0
  1205.     BLT.S    .out
  1206. .loop    CMP.B    #'a',(A0)
  1207.     BLT.S    .lptst
  1208.     CMP.B    #'z',(A0)
  1209.     BGT.S    .lptst
  1210.     EOR.B    #$20,(A0)
  1211. .lptst    ADDQ    #1,A0
  1212.     DBRA    D0,.loop
  1213. .out    RTS
  1214.  
  1215.  
  1216. doScan    loc
  1217.     POP.L    D1    ; D1 = char
  1218.     POP.L    D0    ; D0 = string length - assume only 16 bits
  1219.     MOVE.L    (A6),A0    ; A0 -> string
  1220.     SUBQ    #1,D0
  1221.     BLT.S    .end
  1222. .loop    CMP.B    (A0)+,D1
  1223.     DBEQ    D0,.loop
  1224.     BNE.S    .end
  1225.     SUBQ    #1,A0
  1226. .end    ADDQ    #1,D0
  1227.     MOVE.L    A0,(A6)
  1228.     PUSH.L    D0
  1229.     RTS
  1230.  
  1231. doSkip    loc
  1232.     POP.L    D1    ; D1 = char
  1233.     POP.L    D0    ; D0 = string length - assume only 16 bits
  1234.     MOVE.L    (A6),A0    ; A0 -> string
  1235.     SUBQ    #1,D0
  1236.     BLT.S    .end
  1237. .loop    CMP.B    (A0)+,D1
  1238.     DBNE    D0,.loop
  1239.     BEQ.S    .end
  1240.     SUBQ    #1,A0
  1241. .end    ADDQ    #1,D0
  1242.     MOVE.L    A0,(A6)
  1243.     PUSH.L    D0
  1244.     RTS
  1245.  
  1246.  
  1247. doPlitstr
  1248.     MOVE.L    (A7)+,A1    ; Save return address
  1249.     MOVEQ    #0,D0
  1250.     MOVE.L    (A7),A0
  1251.     MOVE.B    (A0)+,D0
  1252.     PUSH.L    A0
  1253.     PUSH.L    D0
  1254.     ORI.B    #1,D0
  1255.     ADD.L    D0,A0
  1256.     MOVE.L    A0,(A7)
  1257.     JMP    (A1)
  1258.  
  1259.  
  1260.  
  1261. ;    =====================
  1262.  
  1263. ; doNextEvent  ( ^event mask -- b )  is BRA'd to from NextEvent in file nuc2.asm.
  1264. ; We call WaitNextEvent if it's available, otherwise GetNextEvent.
  1265.  
  1266. doNextEvent
  1267.     exVect    TEidle
  1268.     savA5
  1269.     MOVE.L    (A7)+,D2
  1270.     SWAP    D2
  1271.     MOVE.L    (A7),D1
  1272.     MOVE.L    D2,(A7)
  1273.     MOVE.L    D1,-(A7)
  1274.     TST.B    WNEavail+3-base(A3)
  1275.     BEQ.S    .useGNE
  1276.     MOVE.L    sleepTicks,-(A7)
  1277.     MOVE.L    MMRgn,-(A7)
  1278.     _WaitNextEvent
  1279.     BRA.S    .ne1
  1280.  
  1281. .useGNE    _SystemTask
  1282.     _GetNextEvent
  1283.  
  1284. .ne1    CLR.W    -(SP)
  1285.     rstA5
  1286.     tst.b    instldq+3-base(a3)
  1287.     bne.s    .neEnd    ; If this isn't an installed application, we
  1288.     move.l    JmpAbort,$1E4    ; reset the jump to ABORT in scratch20 area
  1289.             ; (so we can easily ABORT from Macsbug).
  1290.             ; Various other programs change it from
  1291.             ; time to time, so we reset it here.
  1292. .neEnd    rts
  1293.  
  1294.  
  1295. ; DoFindWindow is BRA'd to from find-window (in nuc2.asm)
  1296.  
  1297. doFindWindow
  1298.     savA5
  1299.     MOVE.L    (SP)+,D0
  1300.     CLR    -(SP)
  1301.     MOVE.L    D0,-(SP)
  1302.     PEA    TempPtr
  1303.     _FindWindow
  1304.     CLR    -(SP)
  1305.     LEA    TempPtr,A0
  1306.     MOVE.L    (A0),-(A7)
  1307.     rstA5
  1308.     RTS
  1309.  
  1310. ;        ============================
  1311.  
  1312. ;               :PROC support
  1313.  
  1314. ;        ============================
  1315.  
  1316. ; The code at ProcEntry is COPIED to the start of each :proc definition.
  1317. ; This is because at the time the :proc is called, none of our A regs
  1318. ; are set up, so we can't address the dictionary.  We can't even use
  1319. ; PC-relative addressing, since this code will exist at different locations.
  1320. ; The code is:
  1321. ;    move.l    saveEP,a0
  1322. ;    jsr    (a0)
  1323. ; What this code (6 bytes) does, is first to grab the addr of EnterProc from
  1324. ; the A5 globals area where our startup code put it.  We then call EnterProc which
  1325. ; uses PC-relative addressing while it saves the A regs needed for return to the
  1326. ; system from the proc, then sets up the rest of our A regs. Then we're in business.
  1327.  
  1328. SysRegMark    dc.l    $12345
  1329.  
  1330. enterProc
  1331.     move.l    savedRP,a0
  1332.     movem.l    d2-d7/a1-a6,-(a0)
  1333.     movem.l    myRegs,a3-a5
  1334.     move.l    a7,a6
  1335.     move.l    a0,a7
  1336.     move.l    (a6)+,a0    ; Rtn addr from procentry, i.e. dest addr
  1337.     move.l    (a6)+,-(a7)    ; Save rtn addr from system for procexit
  1338.     move.l    SysRegMark,-(a7)    ; Mark rtn stack to catch impending disasters
  1339.     jmp    (a0)    ; Goto proc routine
  1340.  
  1341.  
  1342. ; PROCEXIT is JMPed to at the end of the proc, and then BRAs to doProcExit.
  1343. ; Note: we can't use SavedRP to recover the RP value we left at procEntry since
  1344. ; our multitasking may have changed it if another task did a system call.  But we
  1345. ; check if our special mark is at the top of the rtn stk, as it should be.
  1346.  
  1347. doProcExit
  1348.     move.l    SysRegMark,d0    ; Check the mark is on top of the rtn stk
  1349.     cmp.l    (a7)+,d0
  1350.     bne.s    .peErr    ; Error if not
  1351.     move.l    (a7)+,-(a6)    ; Move system rtn addr to data stack for
  1352.             ;  RTS below (when A7 will point to data stk)
  1353.     move.l    a6,d0
  1354.     lea    savedRP-base(a3),a0
  1355.     movem.l    (a7)+,d2-d7/a1-a6    ; Restore system's regs
  1356.     move.l    a7,(a0)    ; Restore savedRP
  1357.     move.l    d0,a7    ; Set system's SP
  1358.     rts    ; Cheerio
  1359.  
  1360. .peErr    n    60
  1361.     bsr    die    ; "Return stack clobbered by PROC"
  1362.  
  1363.  
  1364. ;    ========================
  1365.  
  1366. ; Exception handlers.  In case the Mac was running in User mode when the
  1367. ; exception occurred, we must save the info we need, then replace the return
  1368. ; address in the A7 stack with the address of the "real" handler, then RTE.
  1369. ; Then the "real" exception handler can run in the normal Mops environment.
  1370.  
  1371.  
  1372. ; The CHK exception vector has been set to point to CHKfailed.  We
  1373. ; figure out what the failing index and limit were, and push them for
  1374. ; the forward defined handler routine RngErr.
  1375.  
  1376.     loc
  1377. CHKRA    long
  1378.  
  1379. CHKfailed
  1380.     movem.l    d0-d2/a0,-(a6)    ; Save regs on data stack - we don't know
  1381.             ;  which we might need to access the index
  1382.             ;  and limit
  1383.     lea    CHKRA,a0
  1384.     move.l    2(a7),(a0)    ; Save return addr in CHKRA
  1385.     lea    CHKfailed1,a0
  1386.     move.l    a0,2(a7)    ; Set rtn addr to real error handler
  1387.     rte
  1388.     
  1389. ;    addq.l    #2,a7    ; Drop status word
  1390.  
  1391. CHKfailed1
  1392.     move.l    CHKRA,a0    ; Return addr to A0
  1393.     move.w    -2(a0),d0    ; Now we locate the CHK instrn - the 68000
  1394.     and.w    #$F1C0,d0    ;  exception stack frame doesn't tell us
  1395.     cmp.w    #$4180,d0
  1396.     beq.s    .1wd
  1397.     move.w    -4(a0),d0
  1398.     and.w    #$F1C0,d0
  1399.     cmp.w    #$4180,d0
  1400.     beq.s    .2wd
  1401.     moveq    #-1,d0
  1402.     push.l    d0
  1403.     bra.s    .jrerr
  1404.  
  1405. .1wd    move.w    #$4E71,d0
  1406.     swap    d0
  1407.     move.w    -2(a0),d0
  1408.     bra.s    .cf1
  1409.  
  1410. .2wd    move.l    -4(a0),d0
  1411.     SWAP    D0
  1412. .cf1    MOVEQ    #0,D1
  1413.     MOVE.W    D0,D1
  1414.     ROL.W    #7,D1    ; First convert it to  PUSH.L Dn
  1415.     AND.W    #7,D1
  1416.     OR.W    #$2D00,D1
  1417.     lea    .ptch1,a0
  1418.     move.w    d1,(a0)    ; Patch it in
  1419.     AND.W    #$003F,D0    ; Now convert the CHK to  MOVE.W  <ea>,D0
  1420.     OR.W    #$3000,D0
  1421.     SWAP    D0
  1422.     lea    .ptch2,a0
  1423.     MOVE.L    D0,(a0)    ; and patch it in too
  1424.     bsr    patchesDone
  1425.     movem.l    (a6)+,d0-d2/a0    ; Restore regs
  1426. .ptch1    NOP        ; Execute  PUSH.L  Dn - the index
  1427. .ptch2    NOP        ; Execute  MOVE.W  <ea>,D0    - the limit-1
  1428.     NOP
  1429.     EXT.L    D0    ; Sign-extend, since negative means
  1430.     ADDQ.L    #1,D0    ;  non-indexed
  1431.     PUSH.L    D0    ; Push limit
  1432.     PUSH.L    A0    ; Push return addr
  1433. .jrerr    ExVect    rngErr    ; Forward
  1434.     dc.w    $FFFF    ; We shouldn't get here
  1435.  
  1436.  
  1437. ;    ==================================
  1438.  
  1439. ; Arithmetic routines for use on 68000 processors.
  1440.  
  1441. ; Unsigned multiplication.
  1442.  
  1443. UMult
  1444. .umult1    tst.w    (a6)    ; If both high-order words are zero,
  1445.     bne.s    .full    ;  we can do a short multiply.
  1446.     tst.w    4(a6)
  1447.     bne.s    .full
  1448.     pop.l    d0    ; Yes, we can.
  1449.     move.l    (a6),d1
  1450.     mulu    d0,d1
  1451.     move.l    d1,(a6)
  1452.     rts
  1453.  
  1454.             ; No, we can't.  Must do a full mult.
  1455. .full    move.l    d3,-(a7)    ; Save D3
  1456.     pop.l    d0
  1457.     move.l    (a6),d1
  1458.     move    d1,d2
  1459.     mulu    d0,d2    ; lo * lo
  1460.     swap    d2    ; For accumulating high half
  1461.     move.l    d1,d3
  1462.     swap    d3
  1463.     mulu    d0,d3    ; hi * lo
  1464.     add.w    d3,d2
  1465.     swap    d0
  1466.     mulu    d1,d0    ; lo * hi
  1467.     add.w    d0,d2    ; Note: we don't need hi * hi as it's
  1468.     swap    d2    ; over the top!
  1469.     move.l    d2,(a6)
  1470.     move.l    (a7)+,d3    ; Restore D3
  1471.     rts
  1472.  
  1473. ; Long signed multiplication.
  1474.  
  1475. SMult    tst    (a6)    ; If either operand is positive, the
  1476.     bpl    .umult1    ; result will be identical to unsigned
  1477.     tst    4(a6)    ; multiplication, so we go straight there.
  1478.     bpl    .umult1
  1479.     neg.l    (a6)    ; Both negative.  Negate them, then
  1480.     neg.l    4(a6)    ; go to unsigned mult routine.
  1481.     bra    .umult1
  1482.  
  1483.  
  1484. ; MulX is used to multiply a potentially longword index value by the width of
  1485. ; each indexed element.
  1486. ; D0 = index, D1 = width.  Leaves result in D0.  Uses D2.
  1487.  
  1488. pMulx    move.l    d0,d2
  1489.     swap    d2
  1490.     mulu    d1,d2
  1491.     swap    d2
  1492.     clr.w    d2
  1493.     mulu    d1,d0
  1494.     add.l    d2,d0
  1495.     rts
  1496.  
  1497.  
  1498. ; Division.
  1499.  
  1500. ; Our software division routines leave the remainder in D0 and the quotient
  1501. ; in D1.
  1502.  
  1503. ; Unsigned 32-bit division.  Code derived from yours truly's PDP-11 implementation,
  1504. ; which I prefer to the original Neon version.
  1505.  
  1506.     loc
  1507. Zdiv    moveq    #25,d0    ; We come here on zero divide
  1508.     push.l    d0
  1509.     bra    ArithErr
  1510.  
  1511.  
  1512. UDiv    tst.l    (a6)    ; First we check for zero div
  1513.     beq.s    Zdiv
  1514.     tst.w    (a6)    ; Is hi-order half of divisor zero?
  1515.     beq    UdivW    ; Yes - we can do it quicker
  1516.  
  1517.     pop.l    d2    ; D2 = divisor
  1518.     move.l    (a6),d1
  1519.     moveq    #0,d0    ; D0/1 = dividend
  1520.     movem.l    d2/d3,-(a7)    ; Set up for div loop - save regs
  1521.     moveq    #31,d3
  1522.  
  1523. .loop    asl.l    #1,d1
  1524.     roxl.l    #1,d0
  1525.     bcs.s    .dosub
  1526.     cmp.l    d2,d0
  1527.     blo.s    .lptest
  1528. .dosub    sub.l    d2,d0
  1529.     addq    #1,d1
  1530. .lptest    dbra    d3,.loop
  1531.  
  1532.     movem.l    (a7)+,d2/d3    ; Restore regs
  1533.     rts
  1534.  
  1535.  
  1536. ; Signed 32-bit division.  We make everything positive, call the Udiv
  1537. ; routine, then go to setSigns to fix the signs up.
  1538.  
  1539. Sdiv    move.l    d3,-(a7)    ; Save D3
  1540.     tst.l    (a6)    ; Test sign of divisor
  1541.     smi    d2    ; Leave flag in d2
  1542.     bpl.s    .sd1
  1543.     neg.l    (a6)
  1544. .sd1    tst.l    4(a6)    ; Test sign of dividend
  1545.     smi    d3    ; Leave flag in d3
  1546.     bpl.s    .sd2
  1547.     neg.l    4(a6)
  1548.  
  1549. .sd2    bsr.s    Udiv    ; Call unsigned div routine Udiv
  1550.  
  1551.     eor.b    d3,d2    ; Set sign of quotient
  1552.     bpl.s    .sd3
  1553.     neg.l    d1
  1554. .sd3    tst.b    d3    ; Set sign of remainder - same as dividend,
  1555.     bpl.s    .rtn    ; which is different from original Neon.
  1556.     neg.l    d0    ; Yes, this was a bug!
  1557. .rtn    move.l    (a7)+,d3    ; Restore D3
  1558.     rts        ;  and return
  1559.  
  1560.  
  1561. ; Word division.  The divisor has 16 sig bits or less.  This allows a quicker
  1562. ; implementation.  Note: this produces a 32-bit quotient, so can't overflow
  1563. ; except for div by zero.
  1564.  
  1565. ; Inner routine to do unsigned word division.  We can do it with two
  1566. ; DIVUs, rather than a loop.
  1567.  
  1568.     loc
  1569. UWdiv    movem.l    d2/d3,-(a7)    ; Save regs
  1570.     move    d1,d2
  1571.     clr    d1
  1572.     swap    d1    ; D1 = Yh
  1573.     divu    d0,d1    ; Divide, giving D1 = Rh:Qh
  1574.     move    d1,d3    ; Save Qh in D3(lo)
  1575.     move    d2,d1    ; D1 = Rh:Yl
  1576.     divu    d0,d1    ; Divide, giving D1 = Rl:Ql
  1577.     move.l    d1,d0
  1578.     clr    d0
  1579.     swap    d0    ; Get remainder to D0 (top 16 bits zero)
  1580.     swap    d1
  1581.     move.w    d3,d1
  1582.     swap    d1    ; Get full quotient to d1
  1583.     movem.l    (a7)+,d2/d3    ; Restore regs
  1584.     rts
  1585.     
  1586.  
  1587. ; Unsigned word division.
  1588.  
  1589. UDivW    pop.l    d0    ; D0 = divisor
  1590.     move.l    (a6),d1    ; D1 = dividend (Yh:Yl)
  1591.     divu    d0,d1    ; Divide
  1592.     bvs    UWdiv    ; If overflow, go do it the hard way
  1593.     move.l    d1,d0
  1594.     clr    d0
  1595.     swap    d0    ; Rem to d0 (top 16 bits zero)
  1596.     swap    d1
  1597.     clr.w    d1
  1598.     swap    d1    ; Quotient to d1 (top 16 bits zero)
  1599.     rts
  1600.  
  1601.  
  1602. ; Signed word division.
  1603.  
  1604. SDivW    pop.l    d0    ; D0 = divisor
  1605.     move.l    (a6),d1    ; D1 = dividend (Yh:Yl)
  1606.     divs    d0,d1    ; Divide
  1607.     bvs.s    .swlong    ; If overflow, go do it the hard way
  1608.     move.l    d1,d0
  1609.     swap    d0
  1610.     ext.l    d0    ; Get sign-extended remainder to D0
  1611.     ext.l    d1    ; and quotient to D1
  1612.     rts
  1613.  
  1614. .swlong    move.l    d3,-(a7)    ; Easy way overflowed.  Save D3
  1615.     tst.l    d0    ; We make everything
  1616.     smi    d2    ; positive then call the unsigned word
  1617.     bpl.s    .swl1    ; division routine.  Signed division
  1618.     neg.l    d0    ; could overflow so we don't try it.
  1619. .swl1    tst.l    d1
  1620.     smi    d3
  1621.     bpl.s    .swl2
  1622.     neg.l    d1
  1623. .swl2    bsr    UWdiv
  1624.  
  1625.     eor.b    d3,d2    ; Set sign of quotient
  1626.     bpl.s    .swl3
  1627.     neg.l    d1
  1628. .swl3    tst.b    d3    ; Set sign of remainder - same as dividend
  1629.     bpl.s    .rtn
  1630.     neg.l    d0
  1631. .rtn    move.l    (a7)+,d3    ; Restore D3
  1632.     rts
  1633.  
  1634. ; Here are the routines that get called from the mult and div words in the
  1635. ; dictionary.
  1636.  
  1637. pSlash    bsr    Sdiv
  1638.     move.l    d1,(a6)    ; Push quotient
  1639.     rts
  1640.  
  1641. pMod    bsr    Sdiv
  1642.     move.l    d0,(a6)    ; Push remainder
  1643.     rts
  1644.  
  1645. pSlMod    bsr    Sdiv
  1646.     move.l    d0,(a6)    ; Push remainder
  1647.     push.l    d1    ; Push quotient
  1648.     rts
  1649.  
  1650. pUSlMod    bsr    Udiv
  1651.     move.l    d0,(a6)    ; Push remainder
  1652.     push.l    d1    ; Push quotient
  1653.     rts
  1654.  
  1655.  
  1656. pSlModW    bsr    SdivW
  1657.     move.l    d0,(a6)    ; Push remainder
  1658.     push.l    d1    ; Push quotient
  1659.     rts
  1660.  
  1661. pUSlModW    bsr    UdivW
  1662.     move.l    d0,(a6)    ; Push remainder
  1663.     push.l    d1    ; Push quotient
  1664.     rts
  1665.  
  1666. ;    ==================================
  1667.  
  1668. ; Indexing code.
  1669.  
  1670.  
  1671. doElem    loc
  1672.     move.l    (a6),d0    ; d0 = index
  1673. idx1    move.l    a2,a0
  1674.     add.w    -2(a0),a0    ; now a0 -> ^class
  1675.     add.w    -2(a0),a0    ; now a0 -> start of indexed area
  1676.     cmp.l    #$00007FFF,-4(a0)
  1677.     bhi.s    .large    ; if #elts > 32k
  1678.     chk    -2(a0),d0    ; bounds check
  1679.     mulu    -6(a0),d0    ; index * width = offset
  1680. .add    add.l    d0,a0
  1681.     move.l    a0,(a6)
  1682.     rts
  1683.  
  1684. .large    move.w    -6(a0),d1    ; #elts > 32k.  Can't use CHK
  1685.     bsr    MulX    ; and need to use MulX
  1686.     bra.s    .add
  1687.  
  1688. doElem1    loc
  1689.     move.l    (a6),d0    ; d0 = index
  1690.     move.l    a2,a0
  1691.     add.w    -2(a0),a0    ; now a0 -> ^class
  1692.     add.w    -2(a0),a0    ; now a0 -> start of indexed area
  1693.     cmp.l    #$00007FFF,-4(a0)
  1694.     bhi.s    .add    ; if #elts > 32k
  1695.     chk    -2(a0),d0    ; bounds check
  1696. .add    add.l    d0,a0
  1697.     move.l    a0,(a6)
  1698.     rts
  1699.  
  1700. doElem2    loc
  1701.     move.l    (a6),d0    ; d0 = index
  1702.     move.l    a2,a0
  1703.     add.w    -2(a0),a0    ; now a0 -> ^class
  1704.     add.w    -2(a0),a0    ; now a0 -> start of indexed area
  1705.     cmp.l    #$00007FFF,-4(a0)
  1706.     bhi.s    .add    ; if #elts > 32k
  1707.     chk    -2(a0),d0    ; bounds check
  1708. .add    add.l    d0,d0    ; index * 2 = offset
  1709.     add.l    d0,a0
  1710.     move.l    a0,(a6)
  1711.     rts
  1712.  
  1713. doElem4    loc
  1714.     move.l    (a6),d0    ; d0 = index
  1715.     move.l    a2,a0
  1716.     add.w    -2(a0),a0    ; now a0 -> ^class
  1717.     add.w    -2(a0),a0    ; now a0 -> start of indexed area
  1718.     cmp.l    #$00007FFF,-4(a0)
  1719.     bhi.s    .shft    ; if #elts > 32k
  1720.     chk    -2(a0),d0    ; bounds check
  1721. .shft    lsl.l    #2,d0    ; index * 4 = offset
  1722.     add.l    d0,a0
  1723.     move.l    a0,(a6)
  1724.     rts
  1725.  
  1726. doIdxBase
  1727.     loc
  1728.     move.l    a2,a0
  1729.     add.w    -2(a0),a0
  1730.     add.w    -2(a0),a0    ; a0 -> 1st indexed elt
  1731.     moveq    #0,d0    ; d0 = dummy zero "index"
  1732.     moveq    #0,d1
  1733.     move.l    -4(a0),d1    ; d1 = limit-1
  1734.     addq.l    #1,d1    ; d1 = limit
  1735.  
  1736. ; Now we execute a CHK to generate a failure if the object isn't indexed,
  1737. ; which is indicated by the limit being negative.  A limit of zero is OK,
  1738. ; which is why we have to use the limit rather than the limit-1 which is
  1739. ; stored in the object.  Note: it is sufficient for our purpose here to
  1740. ; just do a CHK on the high word of the limit, using a dummy value of zero.
  1741. ; This works for all #elts.
  1742. ;
  1743. ; CAREFUL: The diagnostic routine ASSUMES the CHK instruction is 4 bytes
  1744. ; long!  Thus we will have to copy D1 to a mem location, and use that as
  1745. ; the <ea> for the CHK.
  1746.  
  1747.     move.w    d1,ChkLim-base(a3)
  1748.     chk    ChkLim-base(a3),d0
  1749.     push.l    a0
  1750.     rts
  1751.  
  1752.  
  1753. ;    ========== I/O stuff ==========
  1754.  
  1755. dopMake    POP.L    A0
  1756.     savA5
  1757.     _HCreate    ; (A0|IOPB:ParmBlkPtr):D0\OSErr 
  1758.     rstA5
  1759.     EXT.L    D0
  1760.     PUSH.L    D0
  1761.     RTS
  1762.  
  1763. dopOpen    POP.L    D0
  1764.     POP.L    A0
  1765.     MOVE.B    D0,$1B(A0)    ; Set ioPermission
  1766.     savA5
  1767.     _HOpen        ; (A0|IOPB:ParmBlkPtr):D0\OSErr 
  1768.     rstA5
  1769.     EXT.L    D0
  1770.     PUSH.L    D0
  1771.     RTS
  1772.  
  1773. dopClose    POP.L    A0
  1774.     savA5
  1775.     _Close        ; (A0|IOPB:ParmBlkPtr):D0\OSErr 
  1776.     rstA5
  1777.     EXT.L    D0
  1778.     PUSH.L    D0
  1779.     RTS
  1780.  
  1781. dopDelete    POP.L    A0
  1782.     savA5
  1783.     _HDelete        ; (A0|IOPB:ParmBlkPtr):D0\OSErr 
  1784.     rstA5
  1785.     EXT.L    D0
  1786.     PUSH.L    D0
  1787.     RTS
  1788.  
  1789. doPread    loc
  1790.     POP.L    D0    ; Buffer
  1791.     POP.L    D1    ; Count
  1792.     POP.L    A0    ; FCB addr
  1793.     MOVE.L    D0,$20(A0)    ; ioBuffer
  1794.     MOVE.L    D1,$24(A0)    ; ioReqCount
  1795.     savA5
  1796.     MOVE.L    CPaddr,$C(A0)    ; Completion routine
  1797.     BNE.S    .async
  1798.     _Read
  1799.     BRA.S    .rd1
  1800. .async    _ReadAsync
  1801.     clr.l    CPaddr-base(a3)
  1802.  
  1803. .rd1    rstA5
  1804.     EXT.L    D0
  1805.     PUSH.L    D0
  1806.     RTS
  1807.  
  1808. doPwrite
  1809.     loc
  1810.     POP.L    D0
  1811.     POP.L    D1
  1812.     POP.L    A0
  1813.     MOVE.L    D0,$20(A0)    ; ioBuffer
  1814.     MOVE.L    D1,$24(A0)    ; ioReqCount
  1815.     savA5
  1816.     MOVE.L    CPaddr,$C(A0)    ; Completion routine
  1817.     BNE.S    .async
  1818.     _Write
  1819.     BRA.S    .wr1
  1820.  
  1821. .async    _WriteAsync
  1822.     clr.l    CPaddr-base(a3)
  1823.  
  1824. .wr1    rstA5
  1825.     EXT.L    D0
  1826.     PUSH.L  D0
  1827.     RTS
  1828.  
  1829. doPlseek
  1830.     POP.L    D0
  1831.     POP.L    D1
  1832.     POP.L    A0
  1833.     MOVE.L  D0,$2E(A0)    ; $2E = ioPosOffset
  1834.     MOVE    D1,$2C(A0)    ; $2C = ioPosMode
  1835.     savA5
  1836.     _SetFPos    ; (A0|IOPB:ParmBlkPtr):D0\OSErr 
  1837.     rstA5
  1838.     EXT.L    D0
  1839.     PUSH.L    D0
  1840.     RTS
  1841.  
  1842.  
  1843. ;    ========== Screen I/O stuff ===========
  1844.  
  1845. ; These next routines are BRA'd to from Nuc2.asm.  We mustn't do anything significant
  1846. ; if fWind doesn't exist.
  1847.  
  1848. DoScroll    loc
  1849.     tst.b    emitq+3-base(a3)
  1850.     beq.s    .out
  1851.     savA5
  1852.     MOVE.L    (SP)+,D0
  1853.     MOVE.L    (SP)+,D1
  1854.     PEA    FpRect
  1855.     MOVE    D1,-(SP)
  1856.     MOVE    D0,-(SP)
  1857.     MOVE.L    TheRgn-base(A3),-(SP)
  1858.     _ScrollRect ; (dstRect:Rect; dh,dv:INTEGER; updateRgn:RgnHandle)
  1859.     rstA5
  1860. .out    RTS
  1861.  
  1862.  
  1863. DoAtXY    loc
  1864.     savA5
  1865.     PEA    temp
  1866.     _GetPen    ; (VAR pt:Point) 
  1867.     MOVEQ    #0,D0
  1868.     MOVE    temp+2,D0
  1869.     MOVE.L    D0,-(SP)
  1870.     MOVE    temp,D0
  1871.     MOVE.L    D0,-(SP)
  1872.     rstA5
  1873.     RTS
  1874.  
  1875.  
  1876. DrawCurs    loc
  1877.     tst.b    emitq+3-base(a3)
  1878.     beq.s    .end
  1879.     TST.B    curs+3-base(A3)
  1880.     BEQ.S    .end
  1881.     PEA    temp
  1882.     _GetPenState    ; (VAR pnState:PenState)
  1883.     MOVE    #10,-(SP)
  1884.     _PenMode        ; (mode:INTEGER{|XferMode})
  1885.     MOVE    #7,-(SP)
  1886.     CLR    -(SP)
  1887.     _Line        ; (dh,dv:INTEGER)
  1888.     PEA    temp
  1889.     _SetPenState    ; (pnState:PenState)
  1890. .end    RTS
  1891.  
  1892.  
  1893. DoPemit    loc
  1894.     tst.b    emitq+3-base(a3)
  1895.     beq    drop
  1896.     cmp.b    #$D,3(a6)
  1897.     bne.s    .normalEmit
  1898.     addq    #4,a6
  1899.     exVect    crVec
  1900.     rts
  1901.  
  1902. .normalEmit    savA5
  1903.     bsr    DrawCurs
  1904.     addq.l    #2,sp
  1905.     _DrawChar    ; (ch:CHAR) 
  1906.     bsr    DrawCurs
  1907.     rstA5
  1908.     rts
  1909.  
  1910.  
  1911. DoPtype    loc
  1912.     tst.b    emitq+3-base(a3)
  1913.     beq    twoDrop
  1914.     savA5
  1915.     MOVEQ    #0,D0
  1916.     MOVE.W    2(SP),D0
  1917.     SWAP    D0
  1918.     MOVE.L  D0,(A7)
  1919.     _DrawText    ; (textBuf:Ptr; firstByte,byteCount:INTEGER) 
  1920.     bsr.s    DrawCurs
  1921.     rstA5
  1922.     rts
  1923.  
  1924.  
  1925. DoPspaces    tst.l    (a6)
  1926.     ble.s    .out
  1927.  
  1928.     n    padLen
  1929.     bsr    min
  1930.     push.l    pad-base(a3)
  1931.     bsr    swap
  1932.     bsr    twodup
  1933.     fVal    bl
  1934.     bsr    fill
  1935.     bra.s    doPtype
  1936.  
  1937. .out    addq    #4,a6
  1938.     rts
  1939.  
  1940.  
  1941. DoQlead    bsr    thePort
  1942.     pop.l    a0
  1943.     move.w    74(a0),d0    ; Note: high-order garbage in D0
  1944.     beq.s    .sizeZero    ;  will be ignored by *W
  1945.     push.l    d0
  1946.     moveq    #120,d0
  1947.     push.l    d0
  1948.     bsr    starW
  1949.     moveq    #50,d0
  1950.     add.l    d0,(a6)
  1951.     n    100
  1952.     bra    slash
  1953.  
  1954. .sizeZero    n    4    ; Zero point size -- i.e. no font set.
  1955.     rts        ; We just call it 4 so Scroll doesn't
  1956.             ;  crash.
  1957.  
  1958. DoPcr    bsr    dotcur
  1959.     bsr    atxy
  1960.     moveq    #8,d0
  1961.     move.l    d0,4(a6)
  1962.     move.l    (a6),-(a6)
  1963.     bsr    bottom
  1964.     bsr    ge
  1965.     pop.l    d0
  1966.     beq.s    .1
  1967.     n    0
  1968.     bsr    doQlead
  1969.     neg.l    (a6)
  1970.     bsr    doScroll
  1971.     bsr    gotoxy
  1972.     bra.s    .2
  1973.  
  1974. .1    bsr    qlead
  1975.     pop.l    d0
  1976.     add.l    d0,(a6)
  1977.     bsr    gotoxy
  1978. .2    bra    dotcur
  1979.  
  1980.  
  1981. DoPbs    bsr    dotcur
  1982.     push.l    curs
  1983.     clr.l    curs-base(a3)
  1984.     bsr    atxy
  1985.     bsr    swap
  1986.     subq.l    #6,(a6)
  1987.     n    8
  1988.     bsr    max
  1989.     bsr    swap
  1990.     bsr    twodup
  1991.     bsr    gotoxy
  1992.     bsr    space
  1993.     bsr    gotoxy
  1994.     pop.l    curs-base(a3)
  1995.     bra    dotcur
  1996.  
  1997.  
  1998. DoPkey    loc
  1999. .loop    lea    fEvent,a0
  2000.     push.l    a0
  2001.     n    $842A    ; Mask - we'll accept key down, auto-key,
  2002.             ;  mouse-down, high-level and OS events.
  2003.     bsr    nextEvent
  2004.     tst.l    (a6)+
  2005.     beq.s    .loop    ; If no event, keep trying
  2006.     move.w    fEvent,d0    ; Get What field of fEvent to D0
  2007.     cmp.w    #3,d0
  2008.     beq.s    .key    ; key-down or auto-key is a key, as far
  2009.     cmp.w    #5,d0    ;  as we're concerned
  2010.     beq.s    .key
  2011.     cmp.w    #23,d0    ; 23 = kHighLevelEvent
  2012.     bne.s    .loop    ; If not high-level, we ignore it and loop.
  2013.  
  2014. ; High-level event.  We call AEProcessAppleEvent.  If expDicq is then false, it means
  2015. ; that we have either read in the dic in response to an OpenDocuments AppleEvent,
  2016. ; or got an OpenApplication AppleEvent meaning that there won't be a dic coming.  In
  2017. ; these 2 cases we call objInit, then call QUIT to begin regular event
  2018. ; handling.
  2019.  
  2020.     savA5
  2021.     clr.w    -(a7)    ; For return result
  2022.     pea    fEvent    ; theEventRecord = fEvent
  2023.     dc.w    $303C,$021B,$A816    ; AEProcessAppleEvent
  2024.     rstA5
  2025.     tst.w    (a6)+    ; Success?
  2026.     tst.b    expDicq-base(a3)    ; Who cares anyway?
  2027.     bne.s    .loop    ; If we're still waiting for the dic, loop
  2028.  
  2029.     move.l    pErrNum,d0
  2030.     beq.s    .pdk1
  2031.     push.l    d0    ; If a Mops error was returned, raise it
  2032.     bra    die
  2033.  
  2034. .pdk1    push.l    SP0
  2035.     bsr    spstore    ; Clear stack
  2036.     exVect    objinit    ; Initialize system objects
  2037.     bra    quit    ; and goto QUIT
  2038.  
  2039. .key    moveq    #0,d0
  2040.     move.b    fEvent+5,d0    ; Low byte of message field is ASCII key value
  2041.     push.l    d0
  2042.     rts
  2043.  
  2044. ; KeyAcc ( -- c )  Reads one key for ACCEPT.  Handles backspaces and tabs.
  2045.  
  2046. keyAcc    loc
  2047. .loop    exVect    key    ; Forward
  2048.     move.l    (A6),D0
  2049.     cmp.b    #8,D0
  2050.     beq.s    .bs    ; If Backspace
  2051.     cmp.b    #$D,D0
  2052.     beq.s    .cr    ; If CR
  2053.     cmp.b    #3,d0
  2054.     beq.s    .cr    ; If ENTER key, then do CR - 31Jul92 DBH
  2055.     cmp.b    #$FF,D0
  2056.     beq.s    .ff    ; If $FF
  2057.     cmp.b    #9,D0
  2058.     bne.s    .ord
  2059.     moveq    #$20,D0
  2060.     move.l    D0,(A6)    ; Replace tab with blank
  2061. .ord
  2062.     move.l    (a6),-(a6)
  2063.     ExVect    echovec    ; Echo and return char read
  2064.     rts
  2065.  
  2066. .cr    moveq    #$D,d0
  2067.     move.l    d0,(a6)
  2068.     move.l    (a6),-(a6)
  2069.     exVect    echovec    ; Echo and return CR
  2070.     rts
  2071.  
  2072. .ff    addq    #4,a6      ; Ignore FF char (maybe put in by Multifinder)
  2073.     BRA.S    .loop
  2074.  
  2075. .bs    addq    #4,a6    ; Backspace read
  2076.     tst.l    ntib-base(a3)
  2077.     beq.s    .strt    ; At start of TIB?
  2078.     jsr    pbs-base(a3)    ; No - fix screen,
  2079.     subq.l    #1,ntib-base(a3)    ;  back up and loop
  2080.     bra    .loop
  2081.  
  2082. .strt    n    4    ; Yes - beep and loop
  2083.     jsr    beep-base(a3)
  2084.     bra    .loop
  2085.  
  2086.  
  2087. DoAccept    ; ( addr len -- len' )
  2088.     loc
  2089.     clr.l    ntib-base(a3)
  2090.     pop.l    acceptLim-base(A3)    ; Save length
  2091. .loop    bsr    keyAcc
  2092.     pop.l    d0
  2093.     cmp.b    #$D,d0
  2094.     beq.s    .end
  2095.     move.l    ntib-base(A3),D1
  2096.     cmp.l    acceptLim-base(A3),D1
  2097.     bge.s    .loop    ; If at end, don't store char
  2098.  
  2099.     move.l    (a6),a0
  2100.     move.b    d0,(a0,d1.l)
  2101.     addq.l    #1,ntib-base(A3)
  2102.     bra.s    .loop
  2103.  
  2104. .end    move.l    ntib,(a6)
  2105.     rts
  2106.  
  2107. ; REFILL ( -- flag )  attempts to (re)fill the input stream with another line.
  2108.  
  2109. doRefill    loc
  2110.     move.l    sourceID,d0    ; Where are we getting input from?
  2111.     beq.s    .kbd
  2112.     addq.l    #1,d0
  2113.     beq.s    .eval
  2114.     exVect    Frefill    ; A file.  Call Frefill to do the job.
  2115.     rts
  2116.  
  2117. .kbd    bsr    query    ; The keyboard.  Call QUERY
  2118.     n    -1    ;  and return TRUE.
  2119.     rts
  2120.  
  2121. .eval    n    0    ; EVALUATE.  Return FALSE.
  2122.     rts
  2123.  
  2124.  
  2125. ; >NUMBER  ( ud1 addr1 len1 -- ud2 addr2 len2 )
  2126. ;
  2127. ; Here in the nucleus we ignore the high cell of ud1, and return
  2128. ; zero as the high cell of ud2.  LongMath revectors numAccumulate to
  2129. ; give a genuine double result.
  2130.  
  2131.     loc
  2132. doToNumber    move.l    (a6)+,-(a7)
  2133.     move.l    (a6)+,-(a7)
  2134.     tst.l    4(a7)
  2135.  
  2136. .loop    beq.s    .done    
  2137.     moveq    #0,d0
  2138.     move.l    (a7),a0
  2139.     move.b    (a0)+,d0
  2140.     move.l    a0,(a7)
  2141.     push.l    d0
  2142.     push.l    nbase
  2143.     bsr    digit
  2144.     tst.l    (a6)+
  2145.     beq.s    .noDigit
  2146.     exVect    numAccumulate
  2147.     tst.l    dpl-base(a3)
  2148.     bmi.s    .1
  2149.     addq.l    #1,dpl-base(a3)
  2150. .1    subq.l    #1,4(a7)
  2151.     bgt.s    .loop
  2152.  
  2153. .done    move.l    (a7)+,-(a6)
  2154.     move.l    (a7)+,-(a6)
  2155.     rts
  2156.  
  2157. .noDigit    subq.l    #1,(a7)
  2158.     bra.s    .done
  2159.  
  2160.  
  2161. ; pNumAccumulate is the default for NumAccumulate  ( ud1 digit -- ud2 )
  2162. ; which multiplies ud1 by BASE, then adds the digit.  In this nucleus
  2163. ; version we have no double-length arithmetic, so we ignore the hi cell
  2164. ; of ud1, and put zero in the hi cell of ud2.  When LongMath is loaded
  2165. ; NumAccumulate will be re-vectored to a proper double-length version.
  2166.  
  2167. pNumAccumulate
  2168. ; ( ud1 digit -- ud2 )
  2169.     move.l    (a6)+,-(a7)    ; Save digit
  2170.     move.l    nbase-base(a3),(a6)
  2171.     bsr    star    ; Mult lo cell of ud1 by BASE
  2172.     move.l    (a7)+,d0
  2173.     add.l    d0,(a6)    ; Add digit
  2174.     clr.l    -(a6)    ; Push zero as hi cell of ud2
  2175.     rts
  2176.  
  2177. DoNumq
  2178. ; ( addr len -- n true  |  -- false )
  2179.     loc
  2180.     pop.l    d0
  2181.     pop.l    a0
  2182.     clr.l    -(a6)
  2183.     tst.l    d0
  2184.     beq    .noNum
  2185.     clr.l    -(a6)
  2186.     move.b    (a0),d1
  2187.     moveq    #0,d2
  2188.     cmp.b    #$2D,d1    ; Is first char minus?
  2189.     seq    d2
  2190.     move.l    d2,-(a7)    ; Remember if it is
  2191.     beq.s    .nq1
  2192.     addq.l    #1,a0    ; And if so, skip it
  2193.     subq.l    #1,d0
  2194.  
  2195. .nq1    move.l    a0,-(a7)    ; Remember initial addr
  2196.     push.l    a0
  2197.     push.l    d0    ; Setup for >NUMBER
  2198.     moveq    #-1,d0
  2199. .setDpl    move.l    d0,dpl-base(a3)
  2200.     bsr    doToNumber
  2201.     move.l    (a6),d0
  2202.     beq.s    .done
  2203.     move.l    4(a6),a0
  2204.     cmp.b    #$2E,(a0)
  2205.     bne.s    .done
  2206.  
  2207. .decpt    addq.l    #1,4(a6)    ; Decimal point read.  Skip it
  2208.     subq.l    #1,(a6)
  2209.     moveq    #0,d0
  2210.     bra.s    .setDpl
  2211.  
  2212. .done            ; We come here when we've hit a non-digit
  2213.             ;  or string is exhausted. Remaining len
  2214.     pop.l    d0    ;  is on top of stack.
  2215.     bne.s    .badNum    ; If <>0, this is not a valid number
  2216.     pop.l    d0    ; Final addr to D0
  2217.     addq    #4,a6    ; Drop hi cell of number
  2218.     cmp.l    (a7)+,d0    ; Did we process any chars at all?
  2219.     beq.s    .nqFalse    ; No - not a number.
  2220.     tst.l    (a7)+    ; Yes.  Set sign as required
  2221.     beq.s    .nqTrue
  2222.     neg.l    (a6)
  2223. .nqTrue    moveq    #-1,d0    ; And return with True
  2224.     push.l    d0
  2225.     rts
  2226.  
  2227. .nqFalse    addq    #4,a7    ; No chars processed.  Fix rtn stk
  2228. .noNum    rts        ;  and return with False (0 already
  2229.             ;  there on stk)
  2230.     
  2231. .badNum    addq    #8,a7    ; String not all used - bad number.
  2232.     addq    #8,a6    ; Fix stacks
  2233.     clr.l    (a6)    ; and return False
  2234.     rts
  2235.  
  2236.  
  2237. ; Number output
  2238.  
  2239. doEdigs    addq    #8,a6
  2240.     push.l    hld
  2241.     push.l    pad
  2242.     move.l    4(a6),d0
  2243.     sub.l    d0,(a6)
  2244.     rts
  2245.  
  2246. doSign    pop.l    d0
  2247.     bpl.s    .fin
  2248.     n    $2D
  2249.     bsr    hold
  2250. .fin    rts
  2251.  
  2252. doDig    loc
  2253.     move.l    nbase,(a6)    ; Note: this clobbers the hi-order
  2254.     bsr    uslmod    ; cell (assumed to be zero)
  2255.     bsr    swap
  2256.     move.l    (a6),d0
  2257.     cmp.b    #9,d0
  2258.     ble.s    .1
  2259.     addq    #7,d0
  2260. .1    add.w    #$30,d0
  2261.     move.l    d0,(a6)
  2262.     bsr    hold
  2263.     clr.l    -(a6)
  2264.     rts
  2265.  
  2266.  
  2267. doDotr    move.l    (a6)+,-(a7)
  2268.     move.l    (a6),-(a6)
  2269.     bsr    abs
  2270.     n    0
  2271.     bsr    bdigs
  2272.     bsr    digs
  2273.     bsr    rot
  2274.     bsr    doSign
  2275.     bsr    doEdigs
  2276.     move.l    (a6),d0
  2277.     move.l    (a7)+,-(a6)
  2278.     sub.l    d0,(a6)
  2279.     bsr    spaces
  2280.     bra    type
  2281.  
  2282. doUdot    n    0
  2283.     bsr    bdigs
  2284.     bsr    digs
  2285.     bsr    edigs
  2286.     bsr    type
  2287.     bra    space
  2288.  
  2289.  
  2290. ; MARK_FILE and interim disk input
  2291.  
  2292. doMarkFile        ; ( addr len -- )
  2293.     move.l    (a6)+,-(a7)    ; save len
  2294.     push.l    pad-base(a3)
  2295.     move.l    (a7),-(a6)    ; ( addr pad len )
  2296.     jsr    cmove    ; move name to pad
  2297.  
  2298. ; bl pad len + c!      \ append a blank to the file name
  2299.     n    $20
  2300.     push.l    pad-base(a3)
  2301.     move.l    (a7),d0
  2302.     add.l    d0,(a6)
  2303.     jsr    cstore-base(a3)
  2304.  
  2305. ; pad len 1+ sHdr      \ lay down the header
  2306.     push.l    pad-base(a3)
  2307.     move.l    (a7)+,-(a6)
  2308.     addq.l    #1,(a6)
  2309.     bsr    doSHdr
  2310.  
  2311. ; file-mark w,      \ with the file-mark as the "handler code"
  2312.     push.l    fileMark-base(a3)
  2313.     jsr    wcomma-base(a3)
  2314.  
  2315. ; 0 ,  0 w,  0 ,      \ no dir, no log, no date
  2316.     clr.l    -(a6)
  2317.     jsr    comma-base(a3)
  2318.     clr.l    -(a6)
  2319.     jsr    wcomma-base(a3)
  2320.     clr.l    -(a6)
  2321.     jmp    comma-base(a3)
  2322.  
  2323.  
  2324. DoPDkey    loc
  2325.     push.l    fFcb
  2326.     n    1
  2327.     LEA    DiskBuf,A0
  2328.     PUSH.L    A0
  2329.     bsr    pread
  2330.     pop.l    d0
  2331.     move.l    d0,diskErr-base(a3)
  2332.     beq.s    .1
  2333.     exVect    keyst
  2334.     MOVEQ    #-1,D0
  2335.     MOVE.L    D0,curs-base(A3)
  2336.     n    13
  2337.     bra.s    .2
  2338. .1    CLR.L    -(A6)
  2339.     MOVE.B    DiskBuf-base(A3),3(A6)
  2340. .2    rts
  2341.  
  2342.  
  2343. DoLtq    push.l    a2    ; Save A2
  2344.     push.l    fFcb
  2345.     bsr    pclose
  2346.     addq    #4,a6
  2347.     push.l    fFcb
  2348.     n    134
  2349.     bsr    erase
  2350.     clr.l    curs-base(a3)
  2351.     n    $22
  2352.     bsr    word
  2353.     moveq    #0,d0
  2354.     move.l    (a6),a0
  2355.     move.b    (a0),d0
  2356.     addq    #1,d0
  2357.     push.l    d0
  2358.     move.l    fFcb,a2
  2359.     add.w    #182,a2    ; A2 -> filename area at end of fFcb block
  2360.     move.l    a2,-(a7)    ; save on rtn stack
  2361.     push.l    a2
  2362.     bsr    swap
  2363.     bsr    cmove    ; move filename from HERE to fFcb
  2364.     push.l    a2
  2365.     push.l    fFcb
  2366.     bsr    stfptr
  2367.     push.l    fFcb
  2368.     n    1
  2369.     bsr    popen
  2370.     pop.l    d0
  2371.     beq.s    .readit
  2372.     push.l    d0
  2373.     bsr    dot
  2374.     bsr    cr
  2375.     bra    dfltAbort
  2376.  
  2377. .readit    SetVect    pdkey,key
  2378.     pop.l    a2    ; Restore A2
  2379.     move.l    (a7)+,-(a6)    ; push filename addr
  2380.     jsr    count-base(a3)    ; convert to (addr len) for doMarkFile
  2381.     bra    doMarkFile
  2382.  
  2383.  
  2384. ;    ================================
  2385.  
  2386. ; AppleEvents
  2387.  
  2388. doGotParmsq
  2389.     savA5
  2390.     clr.w    -(a7)    ; For return result (OSerr)
  2391.     move.l    fAE,-(a7)    ; TheAppleEvent = fAE
  2392.     move.l    #'miss',-(a7)    ; TheAEKeyword = keyMissedKeywordAttr
  2393.     move.l    #'****',-(a7)    ; desiredType = typeWildCard
  2394.     pea    ignoredActualType    ; typeCode = (ignored)
  2395.     move.l    PAD,-(a7)    ; dataPtr = PAD
  2396.     move.l    #PADlen,-(a7)    ; maximumSize = (size of pad)
  2397.     pea    ignoredActualSize    ; actualSize = (ignored)
  2398.  
  2399.     dc.w    $303C,$0E15,$A816    ; call AEGetParamPtr
  2400.  
  2401.     rstA5
  2402.     pop.w    d0
  2403.     ext.l    d0
  2404.     push.l    d0
  2405.     rts
  2406.  
  2407. ignoredActualType    long
  2408. ignoredActualSize    long
  2409.  
  2410.  
  2411. ;    ============================
  2412.  
  2413. ; Error handling
  2414.  
  2415. doCatch
  2416.     lea    extraLocalsEnd,a0
  2417.     moveq    #19,d0    ; # extraLocals -1
  2418. .ctLoop    move.l    -(a0),-(a7)    ; Save ExtraLocals area
  2419.     dbra    d0,.ctLoop
  2420.     movem.l    d4-d7/a6,-(a7)    ; Save Dn locals and data stk ptr
  2421.     move.l    ThrowHandler,-(a7)    ; and previous handler
  2422.     move.l    #$ABCABC,-(a7)    ; Security marker
  2423.     move.l    a7,ThrowHandler-base(a3)    ; Set current handler
  2424.     bsr    execute    ; Execute returns if no THROW
  2425.     cmp.l    #$ABCABC,(a7)+    ; Security check
  2426.     bne.s    .ctErr
  2427.     move.l    (a7)+,ThrowHandler-base(a3) ; Restore previous handler
  2428.     add.w    #25*4,a7    ; Discard saved info (restored already)
  2429.     clr.l    -(a6)
  2430.     rts
  2431.  
  2432. .ctErr        ; We come here if ThrowHandler doesn't point to a legal
  2433.         ; handler record.  Presumably the rtn stk has been clobbered!
  2434.  
  2435.     msg    Return stack clobbered!
  2436.     n    0
  2437.     n    0
  2438.     bsr    doSvErr
  2439.     bsr    doDotErr
  2440.     bra    dfltAbort
  2441.  
  2442.  
  2443. ; THROW has two entry points.  ThrowWithInfo is used by our normal error
  2444. ; word DIE, and also by ABORT", which save the error info (including the message
  2445. ; string) before calling THROW.  This special entry point signals that the saved
  2446. ; error info is valid.  Our default error handler DfltDie, which is called if no
  2447. ; throw handler has been installed, tests this flag to decide whether to call .ERR to
  2448. ; display the info.
  2449. ; 
  2450. ; The normal entry point doThrow is used if THROW is called directly from code.
  2451. ; It flags the error info invalid, which prevents DfltDie from
  2452. ; calling .ERR and displaying spurious info.
  2453.  
  2454. ThrowWithInfo
  2455.     st    ErrInfoValid-base(a3)
  2456.     bra.s    .th1
  2457.  
  2458. doThrow    sf    ErrInfoValid-base(a3)
  2459. .th1    pop.l    d1    ; Error# to D1
  2460.     beq.s    .thOut
  2461.     move.l    ThrowHandler,d0
  2462.     beq.s    .thDflt    ; No handler - take default action
  2463.     move.l    d0,a0
  2464.     cmp.l    #$ABCABC,(a0)+    ; Security check
  2465.     bne.s    .ctErr
  2466.     move.l    a0,a7    ; We're OK, so set return stk
  2467.     move.l    (a7)+,ThrowHandler-base(a3) ; Restore previous handler
  2468.     movem.l    (a7)+,d4-d7/a6    ; Restore Dn locals and data stk ptr
  2469.     lea    extraLocals,a1
  2470.     moveq    #19,d0    ; # extraLocals -1
  2471. .thLoop    move.l    (a7)+,(a1)+    ; Restore ExtraLocals area
  2472.     dbra    d0,.thLoop
  2473.     move.l    d1,(a6)    ; Replace original xt with err#
  2474. .thOut    rts        ; Return to CATCH caller
  2475.  
  2476. .thDflt    move.l    d1,d0    ; No handler: take default action.
  2477.     addq.l    #1,d0    ; Err# ?
  2478.     beq    dfltAbort    ; -1: do default ABORT
  2479.     addq.l    #1,d0
  2480.     beq    doDfltErr    ; -2: do default ABORT"
  2481.     push.l    d1
  2482.     exVect    dfltDie    ; Anything else: do default DIE
  2483.  
  2484.  
  2485. ; SAVE_ERR ( addr len | err# -1  -- )
  2486. ; saves all the info needed for an error dump, for later use by the default
  2487. ; error-interception routine which may be called after the stacks have been
  2488. ; reset.  This way, THROW can be called
  2489. ; without our having to know if a non-default error-interception routine is
  2490. ; installed or not.  addr and len specifies an error text string, or if
  2491. ; the top of stack is -1 the second cell is the error number whose text
  2492. ; can be typed via TSTR.
  2493. ;
  2494. ; Our normal error word is DIE, which calls SAVE_ERR, then calls
  2495. ; ThrowWithInfo, the alternative entry point to THROW.
  2496.  
  2497.     loc
  2498. svStk    sub.l    a0,d0
  2499.     asr.l    #2,d0
  2500.     move.l    d0,(a1)+
  2501.     ble.s    .ss4
  2502.     moveq.l    #MaxDump,d1    ; max cells we're saving
  2503.     cmp.l    d1,d0
  2504.     ble.s    .ss2
  2505.     move.l    d1,d0
  2506. .ss2    subq.l    #1,d0
  2507. .ss3    move.l    (a0)+,(a1)+
  2508.     dbra    d0,.ss3
  2509. .ss4    rts
  2510.  
  2511.  
  2512. doSvErr    move.l    PtrErrDump,a1
  2513.     pop.l    (a1)+    ; Save the two parms
  2514.     pop.l    (a1)+
  2515.     move.l    a2,(a1)+    ; Save A2 (ptr to current obj)
  2516.     move.l    a6,a0
  2517.     move.l    sp0,d0
  2518.     bsr.s    svStk    ; Save data stack
  2519.     lea    4(a7),a0
  2520.     move.l    rp0,d0
  2521.     bra.s    svStk    ; Save return stack
  2522.  
  2523.  
  2524. ; .ERR displays the error info saved by SAVE_ERR.
  2525.  
  2526. TypeErrNum    msg    Error/$20#/$20
  2527.     push.l    (a6)
  2528.     bra    dot
  2529.  
  2530. doDotErr    loc
  2531.     move.l    PtrErrDump,a0
  2532.     push.l    (a0)+
  2533.     push.l    (a0)+
  2534.     bsr    swap    ; Set up to type err string
  2535.     ExVect    setFwind    ; Redirected to abort word
  2536.             ;  in installed applicns, so we don't
  2537.             ;  try to type to fWind, which may well
  2538.             ;  not exist.
  2539.     ExVect    keyst
  2540.     n    5
  2541.     bsr    beep
  2542.     bsr    cr
  2543.     tst.l    (a6)
  2544.     beq.s    .noMsg
  2545.     bmi.s    .errNum
  2546.     bsr    type
  2547.     bsr    space
  2548.     bra.s    .whr
  2549.  
  2550. .errNum    addq    #4,a6
  2551.     bsr    TypeErrNum
  2552.     msg    :/$20
  2553.     exVect    tstr
  2554.     bra.s    .whr
  2555.  
  2556. .noMsg    addq    #8,a6
  2557.  
  2558. .whr    push.l    srcstart
  2559.     move.l    toin,-(a7)
  2560.     push.l    srclen
  2561.     bsr    cr
  2562.     bsr    type    ; Type error line
  2563.     bsr    cr
  2564.     push.l    (a7)+
  2565.     subq.l    #1,(a6)
  2566.     bsr    spaces
  2567.     n    $5E    ; and error position marker
  2568.     bsr    emit
  2569.     bsr    cr
  2570.  
  2571.     move.l    PtrErrDump,a0
  2572.     addq.l    #8,a0
  2573.     move.l    (a0)+,d0
  2574.     bmi.s    .dotstk
  2575.     push.l    a0
  2576.     push.l    d0
  2577.     msg    Current object:/$20/$20
  2578.     bsr    doDotObjOrRA
  2579.     bsr    cr
  2580.     pop.l    a0
  2581.  
  2582. .dotstk    push.l    a0
  2583.     msg    Stack:
  2584.     setVect    drop,sPrint
  2585.     pop.l    a0
  2586.     move.l    (a0)+,d0
  2587.     bsr    pdotstk
  2588.  
  2589. .dotrs    push.l    a0
  2590.     msg    Return stack:
  2591.     setVect    dotObjOrRA,sPrint
  2592.     pop.l    a0
  2593.     move.l    (a0)+,d0
  2594.     bsr    pdotstk
  2595.     move.l    bigno,DotStkLim-base(a3)
  2596.  
  2597.  
  2598. dfltAbort
  2599.     exVect    abortvec
  2600.     push.l    SP0
  2601.     bsr    spstore
  2602.     push.l    RP0
  2603.     bsr    rpstore
  2604.     bsr    decimal
  2605.     exVect    keyst
  2606.     clr.l    ntib-base(a3)
  2607.     bsr    setsource
  2608.     bsr    plcurs
  2609.     zVal    cstate
  2610.     zVal    localq
  2611.     bsr    quit
  2612.  
  2613.  
  2614. ; doPAbq is called by (ABQ) which is the runtime for ABORT".
  2615.  
  2616. doPAbq
  2617.     jsr    plitstr-base(a3)
  2618.     jsr    rot-base(a3)
  2619.     pop.l    d0
  2620.     beq.s    .1
  2621.     bsr    doSvErr
  2622.     n    -2
  2623.     bra    throwWithInfo
  2624.  
  2625. .1    addq    #8,a6
  2626.     rts
  2627.  
  2628. DoDfltErr
  2629. ;    move.b    fWindQ+3,d0    ; If no fWind, just abort
  2630. ;    beq    dfltAbort
  2631.     move.b    ErrInfoValid,d0
  2632.     beq.s    .noErrInfo
  2633.     move.l    #3,DotStkLim-base(a3)
  2634.     bsr    doDotErr
  2635.     bra    dfltAbort
  2636.  
  2637. .noErrInfo    bsr    TypeErrNum
  2638.     bra    dfltAbort
  2639.  
  2640.  
  2641. SpareRoom    dc.l    200
  2642.  
  2643. doQdp
  2644.     bsr    room
  2645.     pop.l    d0
  2646.     lea    SpareRoom,a0
  2647.     cmp.l    (a0),d0
  2648.     bgt.s    .out
  2649.     clr.l    (a0)
  2650.     n    -8
  2651.     bra    die
  2652.  
  2653. .out    rts
  2654.  
  2655. doQstack
  2656.     move.l    sp0-base(A3),D0
  2657.     cmp.l    A6,D0
  2658.     bge.s    .qsOut
  2659.     move.l    D0,A6
  2660.     move.l    #$AB,(A6)    ; Restore marker in case clobbered
  2661.     n    -4
  2662.     bra    die
  2663.  
  2664. .qsOut    rts
  2665.  
  2666. ;    ==============================
  2667.  
  2668. ; Trim  ( lfa -- latest )  is called by (forget).
  2669.  
  2670.     loc
  2671. trim    MOVE.L    (A6),D0
  2672.     MOVEQ    #7,D1
  2673.     MOVEQ    #0,D2
  2674.     LEA    context,A1
  2675. .tlp1    MOVE.L    (A1),A0
  2676.     ADD.L    A1,A0
  2677. .tlp2    CMP.L    A0,D0
  2678.     BHI.S    .fix
  2679.     MOVE.L    (A0),D3    ; We use D3 = i, but we won't be calling
  2680.     BEQ.S    .fix    ;  this from a DO loop!
  2681.     ADD.L    D3,A0
  2682.     BRA.S    .tlp2
  2683.  
  2684. .fix    CMP.L    A0,D2    ; A0 = reqd addr on this thread
  2685.     BHI.S    .toCxt    ; If higher than previous highest,
  2686.     MOVE.L    A0,D2    ;   replace previous
  2687. .toCxt    SUB.L    A1,A0
  2688.     MOVE.L    A0,(A1)    ; Make relative and replace in context
  2689.     ADDQ.L    #4,A1    ; Look at next thread
  2690.     DBRA    D1,.tlp1    ;  and loop till none left
  2691.  
  2692.     ADDQ.L    #4,D2    ; D2 = highest - convert to nfa for new LATEST
  2693.     MOVE.L    D2,(A6)    ; Return it
  2694.     RTS
  2695.  
  2696.  
  2697. doPforget    loc
  2698.     move.l    fence,d0
  2699.     add.l    a3,d0
  2700.     cmp.l    (a6),d0
  2701.     blo.s    .fg1
  2702.     n    -15
  2703.     bra    die    ; "Invalid FORGET"
  2704.  
  2705. .fg1    push.l    (a6)
  2706.     bsr.s    trim
  2707.     pop.l    latest-base(A3)
  2708.     toVal    dp
  2709.     bra    patchesDone
  2710.  
  2711.  
  2712. ;    ================================
  2713.  
  2714. ; Relocatable and absolute addresses
  2715.  
  2716. ; Reloc! ( src dst -- )  converts the src addr to relocatable and
  2717. ; stores it in the destination.
  2718.  
  2719.  
  2720. doRelocSt
  2721.     pop.l    a0    ; A0 -> destination
  2722. rlSt1    pop.l    d0    ; D0 = addr for conversion.
  2723.             ; Note: DoToVect comes in here.
  2724.     and.l    SAmask,d0    ; Ensure it's a "pure" address
  2725.  
  2726. ; First we look at the source addr, to find if it is in the main dic or
  2727. ; in a module.
  2728.  
  2729.     lea    start,a1
  2730.     cmpa.l    d0,a1
  2731.     bhi.s    .mod    ; If below CODE 2 start, must be a module
  2732.     add.l    DicSize,a1
  2733.     cmpa.l    d0,a1
  2734.     blo.s    .mod    ; If above CODE 2 end, must be a module
  2735.  
  2736. ; It's within CODE 2, but could still be in a module if we're actually compiling
  2737. ; the module.  In this case the addr will be above the start of the A5 addressing
  2738. ; range, as defined by MBcomp which we set when compiling a module.
  2739.  
  2740.     tst.l    CompMod-base(a3)
  2741.     beq.s    .MD    ; Not compiling a mod - it's in the main dic
  2742.     move.l    MBcomp,a1
  2743.     lea    -32766(a1),a1    ; Set A1 to start of A5 addressing range
  2744.     cmpa.l    d0,a1
  2745.     bhi.s    .MD    ; A1 hi - it's in the main dic.
  2746.  
  2747. ; It's in a module being compiled.  We now check if the desination is in the
  2748. ; module. If it isn't, this is generally an error, but is OK if RelocChk? is false.
  2749. ; We set this flag false, for example, when creating an object which may be
  2750. ; in the heap.  We generate reloc addr opcode 6 for this case.  It assumes
  2751. ; that the same module is running whenever the address is used.  If this isn't
  2752. ; done, don't blame me.
  2753.  
  2754.     cmpa.l    a1,a0
  2755.     blo.s    .outOfMod    ; Check for destination low
  2756.     lea    start,a1
  2757.     add.l    DicSize,a1
  2758.     cmp.l    a1,a0    ; Check for destination high
  2759.     bhi.s    .outOfMod
  2760.     bra.s    .modOK
  2761.  
  2762. ; It's in the main dic.  The relocatable addr will be A3-relative, with
  2763. ; opcode 5.
  2764.  
  2765. .MD    sub.l    a3,d0
  2766.     moveq    #5,d1
  2767.     bra.s    .rl1
  2768.  
  2769. ; It's apparently in a running module.  We now check if the destination is in the
  2770. ; module, much as we did above, but the details are a bit different.
  2771.  
  2772. .mod    lea    -32766(a5),a1    ; Check for destination low
  2773.     cmpa.l    a1,a0
  2774.     blo.s    .outOfMod
  2775.     move.l    12(a1),d1    ; Check for destination high - grab module
  2776.     add.l    d1,a1    ;  size from header
  2777.     cmp.l    a1,a0
  2778.     bhi.s    .outOfMod
  2779.  
  2780. .modOK    sub.l    a0,d0    ; Source and dest in the module.
  2781.     moveq    #7,d1    ; The reloc addr will be self-relative, with
  2782.     bra.s    .rl1    ;  opcode 7.
  2783.  
  2784. .outOfMod
  2785.     tst.b    RelocChkq+3-base(A3)
  2786.     bne.s    .rlErr
  2787.     moveq    #6,d1    ; Source in mod, dest out, error inhibited.
  2788.     sub.l    a5,d0    ; The reloc addr will be A5-relative, with
  2789.             ;  opcode 6.
  2790.  
  2791. .rl1    lsl.l    #8,d0
  2792.     move.b    d1,d0
  2793.     ror.l    #8,d0
  2794.     move.l    d0,(a0)
  2795.     rts
  2796.  
  2797. .rlErr    n    71    ; "You can't store a module addr outside
  2798.     bra    die    ;  the module"
  2799.  
  2800.  
  2801. doToBandDComp
  2802.  
  2803. ; Used by the assembler when generating a b-d address.  The client's modbase value
  2804. ; is in MBcomp, so we use that instead of the current A5.
  2805.  
  2806.     move.l    MBcomp,A1
  2807.  
  2808. .bd1    move.l    (a6),d0    ; D0 = addr for conversion
  2809.     move.l    d0,d1
  2810.     add.l    #32766,d1
  2811. ;    cmpa.l    a3,a5    ; If modbase is below lobase, we have to
  2812. ;    blo.s    .a5lo    ;  do things in a different order. This can
  2813.             ;  only happen from a running module, so we
  2814.             ;  only need to worry about it here, not in
  2815.             ;  Handlers.
  2816.     cmp.l    a1,d1    ; A1 = modbase or MBcomp.
  2817.     bhs.s    .useMB
  2818.     cmp.l    a4,d1
  2819.     bhs.s    .useHB
  2820. .useLB    sub.l    a3,d0    ; Use lobase
  2821.     moveq    #3,d1
  2822.     bra.s    .tbd1
  2823.  
  2824. ;.a5lo    cmp.l    a4,d1
  2825. ;    bhs.s    .useHB
  2826. ;    cmp.l    a3,d1
  2827. ;    bhs.s    .useLB
  2828. ;    bra.s    .useMB
  2829.  
  2830. .useHB    sub.l    a4,d0    ; Use hibase
  2831.     moveq    #4,d1
  2832.     bra.s    .tbd1
  2833.  
  2834. .useMB    sub.l    a1,d0    ; Use modbase
  2835.     moveq    #5,d1
  2836.     bra.s    .out    ; Out with no stand-alone code error check,
  2837.             ;  since it is supposed to use modbase
  2838.  
  2839. .tbd1    tst.b    state+3-base(A3)    ; We come here if we're using lobase or 
  2840.             ;  hibase
  2841.     beq.s    .out    ; If we're in execution state, skip check
  2842.     tst.b    SAcomp+3-base(A3)    ; Are we compiling stand-alone code?
  2843.     bne.s    .SAfail    ;   Yes - error
  2844.  
  2845. .out    move.l    d1,(a6)
  2846.     push.l    d0    ; Push results, and out.
  2847.     rts
  2848.  
  2849. .SAfail    n    160    ; "You can't refer to main dic from
  2850.     bsr    die    ;  stand-alone code"
  2851.  
  2852.  
  2853. ; doPAtAbs is the subroutine to convert a relocatable address to absolute.
  2854. ; It is BRA'd to from @abs in the main dictionary, but is also called directly
  2855. ; from various places in the nucleus.
  2856. ; Entered with A0 -> reloc addr, leaves A0 = abs addr.  D0 is clobbered.
  2857. ; Other regs preserved.
  2858.  
  2859. doPAtAbs
  2860.     move.l    (a0),d0
  2861.     rol.l    #8,d0
  2862.     subq.b    #5,d0
  2863.     sne    RAinMod-base(a3)    ; We sometimes need this flag
  2864.     bne.s    .inModule
  2865.     move.l    a3,a0
  2866. .ma1    asr.l    #8,d0
  2867.     add.l    a0,d0
  2868.     and.l    SAmask,d0    ; Leaves CC = NE (unless the addr is of locn
  2869.     move.l    d0,a0    ;  zero, which it has no right to be)
  2870.     rts
  2871.  
  2872. .useModbase
  2873.     move.l    a5,a0
  2874.     bra.s    .ma1
  2875.  
  2876. .inModule
  2877.     subq.b    #1,d0
  2878.     beq.s    .useModbase
  2879.     subq.b    #1,d0
  2880.     beq.s    .ma1
  2881.  
  2882. relocErr            ; Illegal reloc addr found.
  2883.     tst.b    noAbsErr-base(A3)
  2884.     beq.s    .re1    ; Normal case: error trap
  2885.     sf    noAbsErr-base(A3)    ; Special case: caller will handle, so we
  2886.     moveq    #0,d0    ; leave A0 zero and the CC = EQ.
  2887.     move.l    d0,a0
  2888.     rts
  2889.  
  2890. .re1    tst.b    pFindmRunning-base(A3)
  2891.     bne.s    dicNoGood
  2892.     push.l    a0    ; Push the reloc addr and its location
  2893.     push.l    (a0)    ;  so we can maybe find out what went wrong
  2894.     n    70    ; "Not a relocatable addr"
  2895.     jmp    die-base(a3)
  2896.  
  2897. dicNoGood
  2898.     sf    pFindmRunning-base(A3)
  2899.     n    72    ; "Dictionary corrupted"
  2900.     JMP    die-base(A3)
  2901.  
  2902.  
  2903. pRelocType
  2904.     moveq    #0,d0
  2905.     move.b    (a0),d0
  2906.     subq.b    #5,d0
  2907.     bmi.s    relocErr
  2908.     cmp.b    #2,d0
  2909.     bgt.s    relocErr
  2910.     rts
  2911.  
  2912. doRelocType
  2913.  
  2914. ; ( ^reloc-addr -- n )
  2915.  
  2916.     move.l    (a6),a0
  2917.     bsr.s    pRelocType
  2918.     move.l    d0,(a6)
  2919.     rts
  2920.  
  2921.  
  2922. ;        =========================
  2923.  
  2924. ;            MODULE ENTRY ETC.
  2925.  
  2926. ;        =========================
  2927.  
  2928. ; Module entry. This is necessarily a bit long-winded, but we
  2929. ; shouldn't be popping in and out of modules in inner loops.  We hope.
  2930. ; ModEntry is JSR'd to from the IMPORTed word, using this calling sequence:
  2931. ;
  2932. ;    JSR    ModEntry
  2933. ;    dc.w    index
  2934. ;    dc.w    (offset from here to module cfa)
  2935. ;
  2936. ; We preserve A0, since part of this code is used when we are calling a method
  2937. ; in a module, when A0 points to the object.
  2938.  
  2939. doModEnt
  2940.     loc
  2941.     move.l    (a7)+,a1
  2942.     move.w    (a1)+,d2    ; Index of entry point to D2
  2943.     add.w    (a1),a1    ; A1 -> module object
  2944.  
  2945. ModEnt1            ; Method calls come in here
  2946.     movem.l    a0/a1/a5,-(a7)    ; Save regs - we may be
  2947.             ;  coming from a module
  2948. .me1    move.l    (a1),d1    ; Mod handle to D1 for test
  2949.     cmp.l    nilH,d1
  2950.     beq.s    .notin    ; If nil, mod isn't loaded
  2951.     move.l    d1,a0    ; Mod handle to A0
  2952.     tst.w    4(a1)    ; Locked? (combined test of exec_cnt and
  2953.             ;    locked? flag)
  2954.     bne.s    .locked    ; Yes: skip _HLock to save time
  2955.     exg    a6,a7
  2956.     _HLock        ; Lock handle for execution
  2957.     exg    a6,a7
  2958. .locked    addq.b    #1,4(a1)    ; Inc execution count so mod isn't purged
  2959.     move.l    (a0),d0    ; Dereference handle - addr of mod start
  2960.     and.l    SAmask,d0    ; Make sure it's a pure address
  2961.     move.l    d0,a0    ; Addr of mod start to A0
  2962. ;    btst    #2,6(a1)    ; Using modbase for this module?
  2963. ;    bne.s    .me2
  2964.     lea    32766(a0),a5    ; Set A5 = addressing base for mod
  2965.     move.l    a5,myRegs+8-base(a3)    ;  and also save in MyRegs for :proc
  2966. .me2    lea    8(a0),a1
  2967.     add.l    (a1),a1    ; A1 -> exported word table
  2968.     move.l    0(a1,d2.w),d1    ; Grab mod offset to this exported word
  2969.     lea    0(a0,d1.l),a1    ; A1 -> the word we want
  2970.     move.l    (a7)+,a0    ; Restore A0 in case this is a method call
  2971.  
  2972.     jsr    (a1)    ; JSR to module
  2973.  
  2974.     movem.l    (a7)+,a1/a5    ; Restore A1 and A5
  2975.     move.l    a5,myRegs+8-base(a3)    ; Restore old A5 value to MyRegs
  2976.     subq.b    #1,4(a1)    ; Decrement execution count
  2977.     tst.w    4(a1)    ; Module to stay locked?
  2978.     bne.s    .out    ; Yes: out
  2979.     move.l    (a1),a0    ; No: Get handle again
  2980.     exg    a6,a7
  2981.     _HUnlock        ; Unlock it
  2982.     exg    a6,a7
  2983. .out    rts        ;  and we're finished
  2984.  
  2985. .notin    push.l    d2    ; Save D2
  2986.     push.l    a1    ; Push addr of module object
  2987.     exVect    modLoad    ; Load it - DOESN'T POP STACK
  2988.     pop.l    a1    ; Restore D2 and A1
  2989.     pop.l    d2
  2990.     bra.s    .me1    ; And try again
  2991.  
  2992.  
  2993. ; HoldMod activates a module without entering it. We use this for getting
  2994. ; class/method info out of a module.  A0 -> module object.
  2995.  
  2996. HoldMod
  2997.     loc
  2998.     move.l    a0,a1
  2999.     addq    #4,a1    ; Skip the  JSR ModEntry
  3000.     move.w    (a1)+,d2    ; Index of entry point to D2
  3001.     add.w    (a1),a1    ; A1 -> module object
  3002.  
  3003. HoldMod1            ; Enter here if A1 already set up
  3004. .ma1    move.l    (a1),d1    ; Mod handle to D1 for test
  3005.     cmp.l    nilH,d1
  3006.     beq.s    .notin    ; If nil, mod isn't loaded
  3007.     move.l    a1,heldMod-base(a3)    ; Save addr of module in heldMod
  3008.     move.l    d1,a0    ; Mod handle to A0
  3009.     tst.w    4(a1)    ; Locked? (combined test of exec_cnt and
  3010.             ;    locked? flag)
  3011.     bne.s    .locked    ; Yes: skip _HLock to save time
  3012.     exg    a6,a7
  3013.     _HLock        ; Lock handle for execution
  3014.     exg    a6,a7
  3015. .locked    addq.b    #1,4(a1)    ; Inc execution count so mod isn't purged
  3016.     move.l    (a0),d0    ; Dereference handle - addr of mod start
  3017.     and.l    SAmask,d0    ; Make sure it's a pure address
  3018.     move.l    d0,a0    ; Addr of mod start to A0
  3019.     lea    32766(a0),a1    ; Set A1 = addressing base for module
  3020.     move.l    a1,heldMod+4-base(a3)                ; Save in HeldMod+4 in case we need to call
  3021.             ;  the module
  3022.     lea    8(a0),a1
  3023.     add.l    (a1),a1    ; A1 -> exported word table
  3024.     add.l    0(a1,d2.w),a0    ; Grab mod offset to this exported word
  3025.             ;  and add to mod start addr - this is the
  3026.             ;  addr we want.
  3027.     move.w    d2,MethIndex+2-base(a3)                ; Save entry point index in MethIndex - this
  3028.             ;  presumably refers to a class, and the
  3029.             ;  method entries will follow. (findm) will
  3030.     rts        ;  keep track of these.
  3031.  
  3032. .notin    push.l    d2    ; Save D2
  3033.     push.l    a1    ; Push addr of module object
  3034.     clr.l    heldMod-base(a3)    ; So ex-method doesn't think we're calling a
  3035.             ;  held module, which we're not.
  3036.     exVect    modLoad    ; Load it - DOESN'T POP STACK
  3037.     pop.l    a1    ; Restore A1
  3038.     pop.l    d2    ;  and D2
  3039.     bra.s    .ma1    ; And try again
  3040.  
  3041.  
  3042. doQUnHoldMod
  3043.     loc
  3044.     move.l    heldMod,d0
  3045.     beq.s    .out
  3046.     move.l    d0,a1
  3047. unhm1    clr.l    heldMod-base(a3)
  3048.     subq.b    #1,4(a1)    ; Decrement execution count
  3049.     tst.w    4(a1)    ; Module to stay locked?
  3050.     bne.s    .out
  3051.     move.l    (a1),d0    ; If not, unlock handle
  3052.     cmp.l    nilH,d0
  3053.     beq.s    .out    ; But if nil, mod isn't loaded
  3054.     move.l    d0,a0
  3055.     exg    a6,a7
  3056.     _HUnlock
  3057.     exg    a6,a7
  3058. .out    rts
  3059.  
  3060.  
  3061. ; EBmod executes an early bind to a method in a module.  The calling sequence is:
  3062. ;    lea    <obj>,a0
  3063. ;    lea    <mod>,a1
  3064. ;    jsr    EBmod
  3065. ;    dc.w    <index>
  3066. ;    dc.w    flags
  3067.  
  3068. doEBmod    push.l    a0
  3069.     move.l    (a7),a0
  3070.     move.w    (a0)+,d2
  3071.     move.l    a0,(a7)
  3072.     pop.l    a0
  3073.     bra    ModEnt1
  3074.  
  3075.  
  3076. doExMethod
  3077. ; ( ^obj cfa -- )
  3078.     move.l    HeldMod,d0    ; Is there a held module?
  3079.     beq.s    .em1
  3080.  
  3081. ; There is a held module.  We assume we're calling a method in that module.
  3082. ; Class must ensure that the first ex-method after a method lookup is actually
  3083. ; calling that method.
  3084.  
  3085.     movem.l    d0/a5,-(a7)    ; Save HeldMod and modbase
  3086.     move.l    HeldMod+4,a5    ; Reset modbase to module's value
  3087.     clr.l    HeldMod-base(a3)    ; Now it will be executing rather than held,
  3088.             ;  so we clear HeldMod. This also prevents
  3089.             ;  a call to ?UnHoldMod from decrementing the
  3090.             ;  execution count and releasing the module!
  3091.     bsr    .em1    ; Call the module
  3092.     movem.l    (a7)+,a1/a5    ; Restore HeldMod and modbase
  3093.     bra    unhm1    ; And unhold the module.
  3094.  
  3095. .em1    pop.l    a1
  3096.     pop.l    a0
  3097. inlck            ; EXECUTE comes in here too
  3098.     cmp.w    #inlMk_con,(a1)
  3099.     beq.s    .inline
  3100.     cmp.w    #xinfoMk,(a1)
  3101.     beq.s    .xinfo
  3102.     jmp    (a1)
  3103.  
  3104. .inline    addq    #2,a1    ; Inline methods have a 1-byte count
  3105.     moveq    #0,d0    ;  of the text string length
  3106.     move.b    (a1),d0    ; (Note a zero count is OK here)
  3107.     bra.s    .em2
  3108.  
  3109. .xinfo    addq    #2,a1    ; xinfo words have a 2-byte count
  3110.     moveq    #0,d0    ;  of the xinfo info, so that the
  3111.     move.w    (a1),d0    ;  info is aligned (we often grab
  3112.             ;  it by words).
  3113.     beq.s    .emErr    ; But if the count is zero, there's no 
  3114.             ; executable code at all!
  3115. .em2    addq    #2,d0
  3116.     bclr    #0,d0
  3117.     add.w    d0,a1
  3118.     jmp    (a1)
  3119.  
  3120. .emErr    n    -14
  3121.     bra    die    ; "Interpreting a compile-only word"
  3122.  
  3123. ;    =======================
  3124.  
  3125. ; DoPfind is BRA'd to from (FIND).
  3126. ; Stack:
  3127. ; ( string-addr lfa -- cfa flag | -- string-addr false )
  3128.  
  3129.     loc
  3130. DoPfind    POP.L    A0    ; A0 -> link field
  3131.     POP.L    A1    ; A1 -> string for match
  3132.     MOVEM.L    D3/D6/A2/A4,-(A6)    ; Save regs
  3133.  
  3134.     MOVEQ    #0,D2    ; D2 will hold length
  3135.     MOVE.B    (A1),D2    ; D2 = length
  3136.     MOVE.W    (A1)+,D6    ; D6 = len and first byte
  3137.     ST    pFindRunning-base(A3)
  3138.  
  3139. .loop    MOVE.W    D6,D0
  3140.     MOVE.W    4(A0),D1    ; Fast check on len and first byte
  3141.     EOR.W    D1,D0
  3142.     ANDI.W    #$3FFF,D0
  3143.     BEQ.S    .maybe    ; If match, check rest of name
  3144.  
  3145. .no    MOVE.L    (A0),D0    ; No match.  Get next link field
  3146.     BEQ.S    .failed    ; If none, we've failed
  3147.     ADD.L    D0,A0    ; Next lfa to A0
  3148.     BRA.S    .loop    ; and loop
  3149.  
  3150. .failed    MOVEQ    #0,D0    ; Finished.  Not found.
  3151.     SUBQ.L    #2,A1    ; Backup A1 so we return the original
  3152.             ;  string address
  3153. .end    MOVEM.L    (A6)+,D3/D6/A2/A4    ; Restore regs
  3154.     PUSH.L    A1    ; Push address
  3155.     PUSH.L    D0    ; Push flag
  3156.     SF    pFindRunning-base(A3)
  3157.     RTS        ; Return
  3158.  
  3159. .maybe    MOVE.L    A0,A2
  3160.     MOVE.L    A1,A4
  3161.     ADDQ    #6,A2
  3162.     MOVE    D2,D3
  3163.     LSR    #1,D3
  3164.     SUBQ    #1,D3
  3165.     BMI.S    .yes    ; If no more to check, we've found it
  3166.  
  3167. .loop2    CMPM.W    (A2)+,(A4)+
  3168. .lp2tst    DBNE    D3,.loop2
  3169.     BNE.S    .no
  3170.  
  3171. .yes    ADDQ.L    #2,A2    ; Found.  Point A2 to cfa
  3172.     MOVE.L    A2,A1    ; Move to A1 so we'll return it
  3173.     MOVEQ    #-1,D0    ; Result flag = -1
  3174.     BTST.B    #6,4(A0)    ; Test imm bit in length byte
  3175.     BEQ.S    .ppcChk
  3176.     MOVEQ    #1,D0    ; If set, change flag to +1
  3177.  
  3178. ; Now we check if we're compiling PPC code.  If so, this normally requires 4-byte
  3179. ;  alignment of the handler field.  But this could be a word in the 68k part of the
  3180. ;  dictionary.  The way we can tell is that in the PPC dic the pad bytes will always
  3181. ;  be zero, but in the 68k dic this would be the handler field which can never be zero.
  3182. ;  We do all the adjustment here, so that we don't have to have (too much) 68k-specific
  3183. ;  stuff in the PPC code generator.
  3184.  
  3185. ; We assume the initial "handler addr" is even, even if not 4-byte aligned.
  3186. ; The cfa to return is in A1, and the flag is in D0.  We need to preserve D0
  3187. ; and just modify A1 if necessary.
  3188.  
  3189.  
  3190. .ppcChk    tst.b    PPCq+3-base(a3)
  3191.     beq.s    .end    ; not compiling PPC code - do normal return
  3192.     move.l    a1,d2
  3193.     subq.l    #2,d2    ; handler field addr to D2
  3194.     moveq    #3,d1
  3195.     and.l    d2,d1    ; 4-byte aligned?
  3196.     beq.s    .end    ; yes - we're OK already
  3197.     move.w    -2(a1),d1    ; no - is the 'handler field' zero?
  3198.     bne.s    .end    ; no - assume we're in 68k dic so leave alone
  3199.     addq.l    #2,a1    ; yes - assume we're in PPC dic - modify A1
  3200.     bra.s    .end
  3201.  
  3202.  
  3203.  
  3204. ; DoPfindM is BRA'd to from (FINDM).
  3205. ; Stack:
  3206. ; ( hash ^class link-offs -- offs cfa T  |  F )
  3207.  
  3208.     loc
  3209. DoPfindM
  3210.     pop.l    D2    ; D2 = link offset rel to ^class
  3211.     pop.l    A0    ; A0 = ^class
  3212.     pop.l    D1    ; D1 = hash value
  3213.     move.l    d1,hashval-base(a3)    ; Also save in hashval
  3214.     clr.l    boffs-base(A3)    ; Initial base offset = 0
  3215.  
  3216. .fm1    st    pFindmRunning-base(A3)                ; Recursive call from n-way loop
  3217.             ;  comes in here
  3218.     add.w    d2,a0
  3219.     move.l    (a0),d0
  3220.     beq.s    .fail
  3221.  
  3222. .fm2    add.l    d0,a0
  3223.     move.l    (a0)+,d0
  3224.     bpl.s    .Nway
  3225.  
  3226. ; Now we update MethIndex, which keeps track of the index of methods in a
  3227. ; module's exports table. If we are looking in an exported class, then initially
  3228. ; MethIndex will be set to the index for the class itself. So we update it here,
  3229. ; before the comparison, since the last method must correspond to the next index
  3230. ; after the class, and so on backwards.
  3231.  
  3232.     addq.w    #4,MethIndex+2-base(a3)
  3233.     cmp.l    d0,d1
  3234.     beq.s    .found
  3235.  
  3236. .fmNxt    move.l    (a0),d0
  3237.     bne.s    .fm2
  3238.  
  3239. .fail    clr.l    -(a6)
  3240.     bra.s    .out
  3241.  
  3242. .found    MOVE.L    boffs-base(A3),D0    ; base offset to D0 for return
  3243.     CMP.W    #4,D2    ; method or ivar lookup?
  3244.     BEQ.S    .fndM
  3245.     ADD.W    8(A0),D0    ; ivar: return base offs + local ivar offs
  3246.     ADDQ    #4,A0    ;  and ^class
  3247.     BRA.S    .fndRtn
  3248.  
  3249. .fndM    btst    #0,5(a0)    ; method:  look at private flag
  3250.     beq.s    .fndM1    ;  clear: OK
  3251.     tst.b    selfRefq+3-base(a3)    ;  set: check if this is a ref to self
  3252.     beq.s    .fmNxt    ;  not set: treat as no match
  3253.  
  3254. .fndM1    addq    #6,a0    ; To get cfa of method, first look at flags
  3255.  
  3256. .fndRtn    push.l    d0    ; Return offset
  3257.     push.l    a0    ; and cfa
  3258.     moveq    #-1,d0    ; and true
  3259.     push.l    d0
  3260. .out    sf    pFindmRunning-base(A3)
  3261.     rts
  3262.  
  3263.  
  3264. ; Here we process an n-way referring to the superclasses.  This is a list of
  3265. ; class pointers (relocatable), followed by a zero.
  3266. ; The first pointer has been fetched to D0, with A0 pointing to the next one.
  3267.  
  3268. .Nway    move.l    a0,a1    ; A1 -> next class ptr in n-way
  3269.     subq    #4,a0
  3270.     bra.s    .nwChk    ; D0 = 1st class ptr - CC is still OK
  3271.  
  3272. .nwLoop    move.l    a1,a0
  3273.     tst.l    (a1)+
  3274.  
  3275. .nwChk    beq.s    .fail    ; If this is the end of the n-way, sch failed
  3276.     bsr    pRelocType    ; If this reloc addr is a local module ref,
  3277.     subq.b    #2,d0    ;  methindex will need to accumulate over the
  3278.     beq.s    .nwLoc    ;  search, so we don't save and restore it.
  3279.             ;  We'll indicate this by pushing -1 instead.
  3280.     move.l    methindex,d1    ; Otherwise we'll push methindex.
  3281.     bra.s    .nwAbs
  3282.  
  3283. .nwLoc    moveq    #-1,d1
  3284. .nwAbs    bsr    doPAtAbs
  3285.     movem.l    d1/a0/a1,-(a7)    ; Save regs and boffs ready for recursive 
  3286.             ;  call
  3287.     move.l    boffs,-(a7)
  3288.     moveq    #0,d1
  3289.     move.w    -2(a0),d0
  3290.     cmp.w    #class_h,d0
  3291.     bne.s    .nwCkMod    ; If not a normal class, check for module 
  3292.             ;  entry
  3293.     tst.l    HeldMod-base(a3)
  3294.     beq.s    .nw1    ; If we're not holding a mod, no special 
  3295.             ;  action
  3296.     tst.b    RAinMod-base(a3)
  3297.     bne.s    .nw1    ; Likewise if we are holding a mod, but this
  3298.             ;  class is in the module
  3299.  
  3300.             ; It's in the main dictionary.
  3301.     move.l    HeldMod,-(a7)    ; Save HeldMod and its modbase value
  3302.     move.l    HeldMod+4,-(a7)    ;  over recursive call
  3303.     clr.l    HeldMod-base(a3)    ; Clear HeldMod since class isn't in a mod
  3304.     bra.s    .nw0
  3305.  
  3306. .nwCkMod
  3307.     cmp.w    #class_in_mod_h,d0
  3308.     bne    dicNoGood
  3309.  
  3310. .nwSavHM            ; This class is in a (different) module.
  3311.     move.l    HeldMod,-(a7)    ; Save HeldMod and its modbase value
  3312.     move.l    HeldMod+4,-(a7)    ;  over recursive call
  3313.     move.l    d2,-(a7)    ; Save d2 over HoldMod call
  3314.     bsr    HoldMod    ; Hold the new mod
  3315.     move.l    (a7)+,d2
  3316. .nw0    moveq    #-1,d1
  3317.  
  3318. .nw1    move.l    d1,-(a7)    ; Save flag so we know if we are holding
  3319.             ;  a module or not
  3320.  
  3321.     move.l    sups2skip,d0    ; If sups2skip is > 0, we make the search
  3322.     bgt.s    .fakeFailedSch    ;  in this class fail.
  3323.  
  3324. ; **** now here's the recursive call to look in this class
  3325.     move.l    hashval,d1
  3326.     bsr    .fm1
  3327. ; ****
  3328.     tst.l    (a6)    ; Found?
  3329.     bne.s    .nwFnd    ; Yes
  3330.     addq    #4,a6    ; No.  Pop false flag
  3331.     bra.s    .schFailed
  3332.  
  3333. .fakeFailedSch
  3334.     subq.l    #1,sups2skip-base(a3)
  3335. .schFailed    tst.l    (a7)+    ; Have we pushed a module with the current
  3336.             ;  N-way?
  3337.     beq.s    .nw2    ; No
  3338.     bsr    doQUnHoldMod    ; Yes. Unhold the mod we just looked in
  3339.     move.l    (a7)+,HeldMod+4-base(a3)
  3340.     move.l    (a7)+,HeldMod-base(a3)    ; Restore HeldMod etc.
  3341.  
  3342. .nw2    move.l    (a7)+,boffs-base(a3)
  3343.     movem.l    (a7)+,d1/a0/a1    ; Restore boffs and regs
  3344.     tst.l    d1    ; Restore methindex?
  3345.     bmi.s    .nwiv    ; No
  3346.     move.l    d1,methindex-base(a3)    ; Yes
  3347.  
  3348.  
  3349. .nwiv    move.w    12(a0),d1    ; Get ivar length of this class to D1
  3350.     addq.w    #1,d1    ; Align ivar length (embedded objs
  3351.     bclr    #0,d1    ;  must be aligned)
  3352.     addq.w    #2,d1    ; Update current base offset, allowing
  3353.     add.w    d1,boffs+2-base(a3)    ;  for ^class offset, to point to next
  3354.             ;  embedded obj
  3355.     bra.s    .nwLoop    ; And loop.
  3356.  
  3357.             ; Found.
  3358. .nwFnd    tst.l    (a7)+    ; Have we pushed the module with the current
  3359.             ;  N-way?
  3360.     beq.s    .nw4    ; No
  3361.             ; Yes - first hang on to wherever the search
  3362.     push.l    HeldMod    ;  succeeded!
  3363.     addq    #4,a7
  3364.     move.l    (a7)+,d0
  3365.     cmp.l    (a6),d0    ; Look at module with current N-way
  3366.     beq.s    .nw3
  3367.     move.l    d0,HeldMod-base(a3)    ; If different, we're finished with it, so
  3368.     bsr    doQUnHoldMod    ;  we unhold it.
  3369.  
  3370. .nw3    pop.l    HeldMod-base(a3)
  3371.  
  3372. .nw4    move.l    (a7)+,boffs-base(a3)
  3373.     movem.l    (a7)+,d1/a0/a1    ; Restore boffs and regs (throw away D1)
  3374.     move.w    12(a0),d1    ; Get ivar length of this class to D1
  3375.     cmp.w    #4,d2    ; method or ivar lookup?
  3376.     bne.s    .nwRts    ; ivar - just return. True on stack already.
  3377.     tst.w    d1    ; method.  ivar length?
  3378.     bne.s    .nwRts
  3379.     clr.l    8(a6)    ; If zero, we'll return a zero offset
  3380.             ;  since no ivars will be accessed from
  3381.             ;  the method anyway.
  3382. .nwRts    rts
  3383.  
  3384.  
  3385. doObjCfaq
  3386. ; ( cfa -- cfa b )
  3387.     loc
  3388.     move.l    (a6),a0
  3389.     cmp.w    #obj_h,-2(a0)
  3390.     bne.s    .no
  3391.     moveq    #-1,d0
  3392.     push.l    d0
  3393.     rts
  3394.  
  3395. .no    clr.l    -(a6)
  3396.     rts
  3397.  
  3398.  
  3399. doToClass
  3400.  
  3401. ; ( ^obj -- ^class | -- F )
  3402.  
  3403. ; Also leaves the result in A0, and the CC.
  3404. ; We do some preliminary testing for ^obj really being an obj addr, since this
  3405. ; gets called from the stack dumping routine, and we want to avoid bus errors.
  3406.  
  3407.     loc
  3408.     moveq    #-1,d2    ; True means we can go to a module
  3409. toClass1
  3410.     move.l    (a6),d0
  3411.     btst    #0,d0
  3412.     bne.s    .no    ; If "^obj" not even, it isn't an obj addr
  3413.     move.l    d0,a0    ; A0 = ^obj
  3414.     move.l    d0,theObj-base(a3)    ; Save object addr
  3415.     btst    #0,-1(a0)    ; ^class offs must be even
  3416.     bne.s    .no    ; If not, this isn't an object
  3417.     cmp.b    #$FF,-2(a0)    ; Also, ^class offs should be $FFxx
  3418.     bne.s    .no    ; If not, it's not an object
  3419.     add.w    -2(a0),a0    ; Now A0 -> class ptr (reloc)
  3420. ;    move.l    (a0),d0
  3421.     st    noAbsErr-base(a3)
  3422.     bsr    doPAtAbs    ; Now A0 -> class
  3423.     sf    noAbsErr-base(a3)
  3424.     move.l    a0,(a6)
  3425.     beq.s    .no
  3426.     tst.b    d2
  3427.     beq.s    .yes
  3428. toClass2            ; ?>classInMod comes in here
  3429.     cmp.w    #class_h,-2(a0)
  3430.     beq.s    .yes
  3431.     cmp.w    #class_in_mod_h,-2(a0)
  3432.     bne.s    .no
  3433.     bsr    HoldMod
  3434.     move.l    a0,(a6)
  3435. .yes    move.l    a0,theClass-base(a3)
  3436.     move    #0,CCR    ; Success - return CC NE
  3437.     rts
  3438.  
  3439. .no    moveq    #0,d0
  3440.     move.l    d0,(a6)
  3441.     move.l    d0,a0
  3442.     rts
  3443.  
  3444.  
  3445. doQtoClassInMod
  3446.     move.l    (a6),a0
  3447.     bra.s    toClass2
  3448.  
  3449.  
  3450. doToClassCfa
  3451.     loc
  3452.     moveq    #0,d2
  3453.     bsr    doToClass
  3454.     beq.s    .notClass
  3455.     bsr    toName
  3456.     bra    NtoCount
  3457.  
  3458. .notClass
  3459.     clr.l    -(a6)
  3460.     rts
  3461.  
  3462.  
  3463. doObjFindM
  3464.  
  3465. ; ( selID ^obj -- ^obj' cfa )
  3466.  
  3467. ; Finds a method's cfa given a sel ID and an obj addr.
  3468. ; Updates the object's address if necessary - this will happen if the
  3469. ; method turns out to belong to a superclass with a non-zero offset
  3470. ; in the object - i.e. an embedded object.
  3471.  
  3472.     bsr    doToClass
  3473.     beq.s    .notObj
  3474.     move.l    a0,objClass-base(a3)
  3475.     moveq    #4,d0
  3476.     push.l    d0
  3477.     bsr    doPfindM
  3478.     tst.l    (a6)+
  3479.     beq.s    .notFnd
  3480.     move.l    theObj,d0
  3481.     add.l    d0,4(a6)
  3482.     rts
  3483.  
  3484. .notObj
  3485.     n    81
  3486.     bra    die
  3487.  
  3488. .notFnd
  3489.     bsr    cr
  3490.     push.l    objClass
  3491.     bsr    dotid
  3492.     n    108
  3493.     bra    die
  3494.  
  3495.  
  3496. doThread
  3497.     move.l    (a6),a0
  3498.     moveq    #0,d0
  3499.     move.b    (a0),d0
  3500.     andi.b    #$7,d0
  3501.     lsl.b    #2,d0
  3502.     lea    context,a0
  3503.     add.l    d0,a0
  3504.     move.l    a0,(a6)
  3505.     rts
  3506.  
  3507. doFind    exVect    ufind    ; Forward
  3508.     tst.l    (a6)
  3509.     bne.s    .fin
  3510.     addq    #4,a6
  3511.     move.l    extraFind+4,d0
  3512.     beq.s    .find1
  3513.     exDynVect extraFind
  3514.     tst.l    (a6)
  3515.     bne.s    .fin
  3516.     addq    #4,a6
  3517. .find1    move.l    (a6),-(a6)
  3518.     bsr.s    doThread
  3519.     bsr    displace
  3520.     bsr    doPfind
  3521. .fin    rts
  3522.  
  3523.  
  3524. doPcomp
  3525. pcomp1    move.l    (a6),a0
  3526.     move.l    whichCFA,d2
  3527.     clr.l    whichCFA-base(A3)
  3528.  
  3529.     tst.b    PPCq+3-base(a3)
  3530.     beq.s    .pc2
  3531.  
  3532. ; We're compiling PPC code.  This normally requires 4-byte alignment of the handler
  3533. ;  field, but this could be a word in the 68k part of the dictionary.  The way we
  3534. ;  can tell is that in the PPC dic the pad bytes will always be zero, but in the
  3535. ;  68k dic this would be the handler field which can never be zero.  We do
  3536. ;  all the adjustment here, so that we don't have to have (too much) 68k-specific
  3537. ;  stuff in the PPC code generator.
  3538. ; We assume the initial "handler addr" is even, even if not 4-byte aligned.
  3539.  
  3540. ;    subq.l    #2,a0    ; back to handler field
  3541. ;    move.l    a0,d0
  3542. ;    moveq    #3,d1
  3543. ;    and.l    d0,d1    ; 4-byte aligned?
  3544. ;    beq.s    .pcomp2    ; yes - we're OK already
  3545. ;    move.w    (a0),d1    ; no - do 2 zero bytes follow?
  3546. ;    bne.s    .pcomp2    ; no - assume we're in 68k dic so leave alone
  3547. ;    addq.l    #2,a0    ; yes - assume we're in PPC dic - align A0
  3548. ;
  3549. ;.pcomp2    move.w    (a0)+,d0
  3550. ;    ext.l    d0    ; handler code to D0
  3551. ;    move.l    a0,(a6)    ; update cfa in stack
  3552.  
  3553.  
  3554.     move.w    -2(a0),d0
  3555.     ext.l    d0
  3556. comp4ppc            ; We come in here from CallHandlers
  3557.             ;  which already has the handler code in D0
  3558.     push.l    d0    ; pass handler code
  3559.     push.l    d2    ;  and opcode
  3560.     exVect    ppcVec    ;  to the PPC code generator
  3561.     rts        ; and we're done
  3562.  
  3563. .pc2    move.w    -2(a0),d0
  3564.     bpl.s    .inline
  3565.     cmp.w    #inlMk_con,(A0)
  3566.     beq.w    .compinl
  3567.     jumph
  3568.     
  3569. .inline    MOVE    D0,-(A6)
  3570.     CLR    -(A6)
  3571.     bsr    ncomma
  3572.     RTS
  3573.  
  3574. .compinl
  3575.     exVect    Compinline
  3576.     rts
  3577.  
  3578.  
  3579. doExGen
  3580.     loc
  3581.     lea    pcomp,A0
  3582. exgen1    move.l    DP-base(A3),-(a7)    ; Save DP
  3583.     move.l    PPCq-base(a3),-(a7)    ; and PPC?
  3584.  
  3585. ; If we're compiling for the PPC, we're still RUNNING on the 68k (obviously!), so
  3586. ;  we'll force 68k code when in interpret mode.
  3587.     clr.l    PPCq-base(a3)
  3588.  
  3589.     lea    exBuf,a1
  3590.     add.w    ExBoffs+2,a1    ; Work out new DP locn in execution buffer
  3591.     move.l    a1,-(a7)    ; Save new DP over pcomp call
  3592.     move.l    a1,DP-base(A3)    ; Set DP to new value
  3593.  
  3594.     NoOpt        ; Run-time regs won't have valid values
  3595.     jsr    (a0)    ; Compile word at new DP
  3596.     push.l    xJsrBak
  3597.     bsr    comma    ; Plant JSR to ChkOK (which BRA's to 
  3598.             ;  doChkOK). Also blocks any optimization.
  3599.     push.l    ExBoffs
  3600.     bsr    wcomma    ; Save old ExBuf offset in next word
  3601.     move.l    (a7)+,a0    ; A0 = new DP (where compiled
  3602.     move.l    DP,d0    ;  word is)
  3603.     sub.l    a0,d0    ; D0 = length of compiled code
  3604.     add.l    d0,ExBoffs-base(a3)    ; Increment ExBoffs by this amount
  3605.     move.l    (a7)+,PPCq-base(a3)    ; Restore PPC?
  3606.     move.l    (a7)+,DP-base(A3)    ; and old DP
  3607.     bsr    patchesDone
  3608.     jmp    (a0)    ; Execute compiled code
  3609.  
  3610. doChkOK    move.l    (a7)+,a0    ; Hopefully we come back here
  3611.     move.w    (a0),ExBoffs+2-base(a3)    ; Restore old ExBuf offset
  3612.     bsr    qstack
  3613.     rts
  3614.  
  3615.  
  3616. ; INTERPRET is the interpretation loop.  It calls doInterpret.  Words from the
  3617. ; input stream are interpreted until the input is exhausted.
  3618.  
  3619. doInterpret
  3620.     loc
  3621. .loop    bsr    qstack
  3622.     exVect    logvec
  3623.     moveq    #$20,d0
  3624.     push.l    d0    ; Blank
  3625.     bsr    skipsrc    ; Skip initial blanks - don't call QUERY
  3626.     move.l    toin,d0
  3627.     cmp.l    srclen-base(a3),d0
  3628.     bge.s    .out    ; Out if source exhausted
  3629.     bsr    defined
  3630.     tst.l    (a6)+
  3631.     beq.s    .trynum    ; Not defined - go check for number
  3632.     bgt.s    .imm    ; It's immediate
  3633.     tst.w    state+2-base(A3)    ; Not immediate, but what is STATE?
  3634.     beq.s    .exec    ; Zero = execution state.  Execute the word
  3635.     bsr    pcomp    ; Compilation state.  Compile the word
  3636.     bra.s    .loop    ;  and loop.
  3637.  
  3638. ; We come here if the word is immediate.  As the word may have just been
  3639. ; compiled, we call patchesDone first, to ensure we don't get stale instructions
  3640. ; in the cache.  We use EXECUTE rather than EX-GEN which would have been
  3641. ; a lot slower, and would block optimization of any code being compiled.
  3642. ; But note, we must ensure immediate words can be JSR'd to!
  3643.  
  3644. .imm    bsr    patchesDone
  3645.     bsr    execute
  3646.     bra.s    .loop
  3647.  
  3648. ; We come here if we're in interpret state.  We execute the word via
  3649. ; EX-GEN, since all words are possible here.
  3650.  
  3651. .exec    bsr    doExGen
  3652.     bra.s    .loop
  3653.  
  3654. ; Word not found.  Check for a number.
  3655.  
  3656. .trynum    exVect    Fnumq    ; First check for a floating number
  3657.     tst.l    (a6)+    ;  (will return false if FP not loaded)
  3658.     bne.s    .loop    ; Yes, got it.  Loop
  3659.     bsr    number    ; No: try for ordinary number.  Fails if not
  3660.     tst.w    state+2-base(A3)
  3661.     beq.s    .loop    ; Interpreting.  Nothing more to do.  Loop.
  3662.     bsr    literal    ; Compiling.  Compile number as a literal
  3663.     bra.s    .loop    ; and loop.
  3664.  
  3665. .out    rts
  3666.  
  3667.  
  3668. doOK    loc
  3669.     move.b    echoQ,d0
  3670.     beq.s    .out
  3671.     n    62    ; >
  3672.     bra    emit
  3673.  
  3674. .out    rts
  3675.  
  3676.  
  3677. doQuit    loc
  3678.     bsr    lbrack
  3679.     exVect    quitvec
  3680. .loop    bsr    doQdp
  3681.     push.l    rp0
  3682.     bsr    rpstore
  3683.     tst.w    state+2-base(A3)
  3684.     beq.s    .ok
  3685.     n    3
  3686.     bsr    spaces
  3687.     bra.s    .q1
  3688.  
  3689. .ok    bsr    doOK
  3690.  
  3691. .q1    bsr    query
  3692.     bsr    doInterpret
  3693.     bra.s    .loop
  3694.  
  3695.  
  3696. doPheader
  3697.     loc
  3698.     bsr    alignDP
  3699.     bsr    doQdp
  3700.     bsr    here
  3701.     n    0
  3702.     bsr    comma
  3703.     move.l    dp,latest-base(A3)
  3704.     bsr    Mword
  3705.     tst.b    warnings+3-base(A3)
  3706.     beq.s    phdr1
  3707.     move.l    (a6),-(a6)
  3708.     bsr    doFind
  3709.     move.l    (a6)+,(a6)
  3710.     tst.l    (a6)+
  3711.     beq.s    phdr1
  3712.     bsr    cr
  3713.     move.l    (a6),-(a6)
  3714.     bsr    count
  3715.     bsr    type
  3716.     bsr    space
  3717.     msg    redefined
  3718.  
  3719. phdr1    bsr    doThread    ; Get thread head addr in CONTEXT
  3720.     move.l    (a6),-(a6)
  3721.     bsr    displace
  3722.     pop.l    d0    ; D0 -> previous link field
  3723.     pop.l    a0    ; A0 -> thread
  3724.     pop.l    a1    ; A1 -> HERE (the new LF)
  3725.     move.l    a1,d2
  3726.     sub.l    a0,d2
  3727.     move.l    d2,(a0)    ; Store relative link in thread head
  3728.     sub.l    a1,d0    ; Make prev link relative
  3729.     move.l    d0,(a1)    ; and store it at HERE (the new LF)
  3730.     bsr    here
  3731.     move.l    (a6),a0
  3732.     moveq    #0,d0
  3733.     move.b    (a0),d0
  3734.     addq.l    #1,d0
  3735.     push.l    d0
  3736.     bsr    aligned
  3737.     bsr    allot
  3738.     n    $80
  3739.     bsr    swap
  3740.     bra    cset
  3741.  
  3742.  
  3743. doSHdr
  3744.     bsr    alignDP
  3745.     bsr    here
  3746.     n    0
  3747.     bsr    comma
  3748.     move.l    dp,latest-base(a3)
  3749.     bsr    down
  3750.     bsr    here
  3751.     bsr    place
  3752.     bsr    here
  3753.     move.l    (a6),-(a6)
  3754.     bsr    count
  3755.     bsr    upper
  3756.     bra.s    phdr1
  3757.  
  3758.  
  3759. ;    =============  >MARK, >RESOLVE etc.  ================
  3760.  
  3761. ; A >MARK pushes 3 cells - the top cell is used for ?PAIRS, the second is the
  3762. ; addr of the branch to be resolved (actually the addr just after the opcode word).
  3763. ; The 3rd cell is for flags.  So far we use bit 0 of the third byte to inhibit shortening
  3764. ; the branch in situations where shortening the branch (and moving the code) would
  3765. ; clobber something else (e.g. for the ELSE branch).
  3766. ; The low byte we use for conditional compilation, as a copy of CCmpFlg which is
  3767. ; set by Handlers.  The values of this byte are:
  3768. ;
  3769. ;    0    normal
  3770. ;    1    always branch
  3771. ;    2    never branch
  3772. ;
  3773. ; For a forward "always branch" situation, >RESOLVE actually deletes the
  3774. ; code being branched over (which could never be executed).
  3775.  
  3776.  
  3777. chkCCmp        ; ( -- flg )
  3778.     moveq    #0,d0
  3779.     move.b    CCmpFlg-base(a3),d0
  3780.     push.l    d0
  3781.     clr.b    CCmpFlg-base(a3)
  3782.     rts
  3783.  
  3784. doFmark        ; ( -- flags link 120 )
  3785.     addq.b    #1,fmkCnt-base(A3)
  3786.     bsr    chkCCmp
  3787.     bsr    here
  3788.     n    120
  3789.     tst.b    11(a6)    ; look at conditional compilation flag
  3790.     beq.s    .2
  3791.     rts
  3792.  
  3793. .2    n    0
  3794.     bra    wcomma
  3795.  
  3796.  
  3797. doFresolve
  3798.     loc
  3799.     subq.b    #1,fmkCnt-base(A3)
  3800.     noOpt        ; Mustn't optimize here
  3801.     n    120
  3802.     bsr    qpairs
  3803.     pop.l    a0    ; Saved DP value to A0
  3804.     move.l    a0,d0
  3805.     addq.l    #2,d0
  3806.     move.l    d0,frNxtDP-base(a3)    ; Save DP of instrn after branch
  3807.             ;  for REPEAT and CASE[
  3808.  
  3809. ;    move.l    a0,frBrAd-base(A3)    ; Also save it in frBrAd for REPEAT
  3810.     pop.l    d1    ; Flags to d1
  3811.     tst.b    d1    ; Lo byte is conditional compilation flag
  3812.     beq.s    .2
  3813.     subq.b    #1,d1    ; Do conditional compilation
  3814.     bne.s    .1
  3815.     move.l    a0,DP-base(A3)
  3816. .1    rts
  3817.  
  3818. ; Not conditional compilation
  3819.  
  3820. .2    move.l    DP,d0
  3821.     sub.l    a0,d0
  3822.     cmp.w    #2,d0
  3823.     bne.s    .3
  3824.  
  3825. ; displ will be zero - we can't compile a zero-displ branch (which would look like a
  3826. ; long branch), so we just take the easy way out and compile a NOP then go back and
  3827. ; try again.
  3828.  
  3829.     move.l    #$4E71,-(a6)
  3830.     bsr    wcomma
  3831.     bra.s    .2
  3832.  
  3833. ; Now we see if we can change the branch to short.  If so, we'll have to move the
  3834. ; code in the basic block back by 2 bytes.  There are a couple of circumstances
  3835. ; where this mustn't happen, so we check for these first.
  3836.  
  3837. .3    btst    #8,d1    ; If dontShorten was done when branch
  3838.     bne.s    .long    ;  was compiled, don't do it
  3839.     tst.b    callOut-base(a3)    ; If handlers has compiled a BSR out
  3840.     bne.s    .long    ;  of the block, we can't move it
  3841.     tst.l    moveCodeQ-base(a3)    ; If the calling code has
  3842.     beq.s    .long    ;  inhibited the move for some reason
  3843.             ;  best known to to itself, we don't do it
  3844.     move.b    -2(A0),D1
  3845.     and.b    #$F0,D1    ; And finally...
  3846.     cmp.b    #$60,D1    ;  if instrn we're resolving isn't actually
  3847.     bne.s    .long    ;  a branch, we can't move the code
  3848.     cmpi.l    #128,D0
  3849.     bge.s    .long
  3850.  
  3851. ; Now we're going to move the code:
  3852.  
  3853.     subq.l    #2,dp-base(a3)
  3854.     subq    #2,d0
  3855. ;    subq.l    #1,frBrAd-base(a3)    ; Note: odd value indicates short branch
  3856.     subq.l    #2,frNxtDP-base(a3)
  3857.     move.b    D0,-1(A0)
  3858.     move.l    A0,A1
  3859.     addq    #2,A0
  3860.     _BlockMove
  3861.     rts
  3862.     
  3863. .long    move.w    d0,(a0)
  3864.     rts
  3865.  
  3866. doBresolve
  3867.     loc
  3868.     clr.b    brSh-base(A3)
  3869.     n    121
  3870.     bsr    qpairs
  3871.     move.b    CCmpFlg,D0    ; Conditional compilation flag
  3872.     beq.s    .2
  3873.     subq.b    #1,D0    ; Do conditional compilation
  3874.     beq.s    .1
  3875.     addq.l    #4,A6
  3876.     rts
  3877.  
  3878. .1    bsr    compbr
  3879. .2    pop.l    D1    ; Saved DP value
  3880.     move.l    dp,A0
  3881.     sub.l    A0,D1
  3882.     cmpi.l    #-128,D1
  3883.     sge    brSh-base(A3)
  3884.     bge.s    .short
  3885.     push.l    D1
  3886.     bra    wcomma
  3887.  
  3888. .short    move.b    D1,-1(A0)
  3889. .getout    rts
  3890.  
  3891.  
  3892. doElse    loc
  3893.     n    120
  3894.     bsr    qpairs
  3895.     n    120
  3896.     move.b    11(A6),D0    ; Check conditional compilation flag
  3897.             ; (3rd cell down, lo byte)
  3898.     beq.s    .1
  3899.     move.b    11(A6),D0    ; Doing conditional compilation
  3900.     eor.b    #3,D0    ; Flip condition for ELSE stub
  3901.     move.b    D0,CCmpFlg-base(A3)
  3902.     bsr    doFresolve
  3903.     bra    fmark
  3904.  
  3905. .1    bsr    compbr    ; Normal compilation
  3906.     n    0
  3907.     bsr    wcomma
  3908.     bsr    doFresolve
  3909.     subq.l    #2,dp-base(A3)
  3910.     bsr    fmark
  3911.     bra    dontShorten
  3912.  
  3913.  
  3914. doRepeat    ; ( 119 while-info [...while-info] begin-info -- )
  3915.  
  3916. ; The "natural" way to handle this would be to resolve the branch back (using
  3917. ; the begin-info) first, then handle the forward branch from the WHILE.  This
  3918. ; is what we'll do on PowerPC.  But on the 680x0 because branches can be long
  3919. ; or short, it's actually easier to do it the other way around.
  3920.  
  3921.     loc
  3922.     bsr    compbr    ; Compile dummy branch which we'll
  3923.     n    0    ;  fix up shortly - it will become the
  3924.     bsr    wcomma    ;  back branch to the BEGIN
  3925.     move.l    (a6)+,-(a7)
  3926.     move.l    (a6)+,-(a7)    ; Save (2-cell) BEGIN info
  3927.  
  3928. .resWhlLp    moveq    #119,d0
  3929.     cmp.l    (a6),d0
  3930.     beq.s    .resBegin
  3931.     bsr    doFresolve    ; Resolve fwd branch from WHILE
  3932.     bra.s    .resWhlLp
  3933.  
  3934. .resBegin    addq.l    #4,a6
  3935.     subq.l    #2,dp-base(A3)    ; Move DP back to dummy offset
  3936.     move.l    (a7)+,-(a6)
  3937.     move.l    (a7)+,-(a6)    ; Restore BEGIN info
  3938.     bsr    doBresolve    ; Resolve branch back to BEGIN
  3939.     tst.b    brSh-base(A3)    ; Was it short?
  3940.     beq.s    .getout    ; No - we're finished.
  3941.  
  3942.     move.l    frNxtDP,a0    ; Yes - we need to adjust the offset in the
  3943.             ;  WHILE-branch by 2 bytes.  Note that
  3944.             ;  this branch must be short too, since
  3945.             ;  the distance can't possibly be greater.
  3946.             ;  (Here's where we get the payoff from
  3947.             ;  resolving in reverse order).
  3948.  
  3949. ;    subq.b    #2,-1(a0)    ; &&&&
  3950.  
  3951.     clr.l    -(a6)    ; &&&& testing here!!
  3952.     bsr    wcomma
  3953.  
  3954. .getout    rts
  3955.  
  3956.  
  3957. doCfaq    loc
  3958. ; ( addr -- addr b )
  3959.     move.l    (a6),d0
  3960.     btst    #0,d0
  3961.     bne.s    .no    ; Can't be a CFA if odd
  3962.     and.l    SAmask,d0
  3963.     lea    start,a0
  3964.     cmp.l    d0,a0
  3965.     bhi.s    .no    ; Or if below the dictionary start
  3966.     add.l    DicSize,a0
  3967.     cmp.l    d0,a0
  3968.     blo.s    .no    ; Or if above the end of the dic
  3969.     moveq    #-1,d0
  3970.     push.l    d0
  3971.     rts
  3972.  
  3973. .no    clr.l    -(a6)
  3974.     rts
  3975.  
  3976.  
  3977. doClassq
  3978. ; ( cfa -- cfa b )
  3979. ; Returns true if the cfa refers to a class.
  3980.     move.l    (a6),a0
  3981.     moveq    #0,d0
  3982.     cmp.w    #class_h,-2(a0)
  3983.     beq.s    .yes
  3984.     cmp.w    #class_in_mod_h,-2(a0)
  3985.     bne.s    .out
  3986. .yes    move.l    a0,theClass-base(a3)
  3987.     moveq    #-1,d0
  3988. .out    push.l    d0
  3989.     rts
  3990.  
  3991.  
  3992. ;    ==============================
  3993.  
  3994.     loc
  3995. DoRAq
  3996. ; ( addr -- b )
  3997.     jsr    cfaq-base(a3)
  3998.     tst.l    (a6)+
  3999.     beq.s    .no
  4000.     pop.l    a0
  4001.     MOVE.L    A0,D0
  4002.     CMP.B    #$61,-2(A0)
  4003.     BEQ.S    .short
  4004.     SUBQ    #2,A0
  4005.     MOVE.L    A0,D0
  4006.     CMP.W    #$6100,-2(A0)
  4007.     BEQ.S    .long
  4008.     MOVE.L    A3,D0
  4009.     CMP.W    #$4EAB,-2(A0)    ; JSR  xx(A3)
  4010.     BEQ.S    .based
  4011.     MOVE.L    A4,D0
  4012.     CMP.W    #$4EAC,-2(A0)    ; JSR  xx(A4)
  4013.     BEQ.S    .based
  4014.     CMP.W    #$4EAD,-2(A0)    ; JSR  xx(A5)
  4015.     BEQ.S    .based
  4016.  
  4017. .short    MOVE.B    -1(A0),D1
  4018.     EXT.W    D1
  4019.     BRA.S    .long1
  4020. .long
  4021. .based    MOVE.W    (A0),D1
  4022. .long1    EXT.L    D1
  4023.     ADD.L    D1,D0
  4024.     MOVE.L    D0,TheCFA-base(A3)
  4025.     moveq    #-1,d0
  4026.     push.l    d0
  4027.     rts
  4028.  
  4029. .no    clr.l    (a6)
  4030.     rts
  4031.  
  4032.  
  4033. doDotObjOrRA
  4034.     bsr    objq
  4035.     TST.L    (A6)+
  4036.     BEQ.S    .tryRA
  4037.  
  4038.     SUBQ.L    #8,(A6)
  4039.     bsr    dotid
  4040.     n    4
  4041.     bsr    spaces
  4042.     PUSH.L    theClass
  4043.     bsr    classq
  4044.     TST.L    (A6)+
  4045.     BEQ.S    .drOut
  4046.     msg    Class:/$20/$20
  4047.     bra    dotid
  4048.  
  4049. .drOut    addq    #4,a6
  4050.     rts
  4051.  
  4052. .tryRA    bsr    raq
  4053.     TST.L    (A6)+
  4054.     BEQ.S    .out
  4055.     PUSH.L    TheCFA
  4056.     bsr    dotid
  4057. .out    RTS
  4058.  
  4059.  
  4060.     loc
  4061. saveNbase    long
  4062.  
  4063. pDotStk
  4064. ; D0 = count of cells to display, A0 -> first location.
  4065. ; A0 gets updated to locn for next dump.  DotStkLim gives a maximum
  4066. ; -- this can be used to keep info from scrolling off the screen.
  4067.  
  4068.     push.l    a0    ; Move addr and count to stack
  4069.     push.l    d0    ; so they don't get clobbered
  4070.     lea    savenbase,a0
  4071.     move.l    nbase,(a0)
  4072.     clr.l    out-base(a3)
  4073.     tst.l    d0
  4074.     ble    .chk    ; If stk empty, chk for underflow
  4075. .pds1    push.l    d0
  4076.     msg    /$20/$20Depth/$20
  4077.     jsr    dot-base(a3)    ; and print depth message
  4078.     moveq    #MaxDump,d1
  4079.     cmp.l    (a6),d1
  4080.     bge.s    .pds2
  4081.     move.l    d1,(a6)    ; MaxDump is a hard limit
  4082.  
  4083. .pds2    move.l    (a6),d0
  4084.     asl.l    #2,d0
  4085.     add.l    4(a6),d0
  4086.     move.l    d0,-(a7)    ; Save "next" dump addr on rtn stk
  4087.     move.l    DotStkLim,d1    ; DotStkLim is a temporary limit
  4088.     cmp.l    (a6),d1
  4089.     bge.s    .loop
  4090.     move.l    d1,(a6)
  4091.  
  4092. .loop    jsr    qPause-base(a3)
  4093.     jsr    cr-base(a3)
  4094. .pd2    move.l    4(a6),a0
  4095.     move.l    (a0),-(a6)
  4096.     move.l    (a6),-(a6)
  4097.     move.w    #10,nbase+2-base(a3)
  4098.     n    8
  4099.     jsr    dotval-base(a3)
  4100.     move.l    (a6),-(a6)
  4101.     move.w    #16,nbase+2-base(a3)
  4102.     n    36
  4103.     jsr    emit-base(a3)
  4104.     n    6
  4105.     jsr    dotr-base(a3)
  4106.     jsr    space-base(a3)
  4107.     jsr    sPrint-base(a3)
  4108.     n    3
  4109.     jsr    spaces-base(a3)
  4110.  
  4111. .lptst    addq.l    #4,4(a6)    ; Increment addr
  4112.     subq.l    #1,(a6)    ; Decrement count
  4113.     bgt.s    .loop
  4114.  
  4115. .fin    move.l    savenbase,nbase-base(A3)
  4116.     jsr    cr-base(a3)
  4117.     addq.l    #8,a6
  4118.     move.l    (a7)+,a0    ; "Next" dump address
  4119.     rts
  4120.  
  4121. .chk    beq.s    .empty
  4122.     msg    /$20underflow
  4123.     bra.s    .chk1
  4124.  
  4125. .empty    msg    /$20empty
  4126. .chk1    move.l    4(a6),-(a7)    ; Set "next" dump addr
  4127.     bra.s    .fin
  4128.  
  4129.  
  4130. doDots
  4131.     bsr    mnCurs
  4132.     msg    Stack:
  4133.     setVect    drop,sPrint
  4134.     move.l    sp0,d0
  4135.     sub.l    a6,d0
  4136.     asr.l    #2,d0
  4137.     move.l    a6,a0
  4138.     bra    pdotstk
  4139.